Back to index

plt-scheme  4.2.1
error.c
Go to the documentation of this file.
00001 /*
00002   MzScheme
00003   Copyright (c) 2004-2009 PLT Scheme Inc.
00004   Copyright (c) 1995-2001 Matthew Flatt
00005 
00006     This library is free software; you can redistribute it and/or
00007     modify it under the terms of the GNU Library General Public
00008     License as published by the Free Software Foundation; either
00009     version 2 of the License, or (at your option) any later version.
00010 
00011     This library is distributed in the hope that it will be useful,
00012     but WITHOUT ANY WARRANTY; without even the implied warranty of
00013     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
00014     Library General Public License for more details.
00015 
00016     You should have received a copy of the GNU Library General Public
00017     License along with this library; if not, write to the Free
00018     Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
00019     Boston, MA 02110-1301 USA.
00020 
00021   libscheme
00022   Copyright (c) 1994 Brent Benson
00023   All rights reserved.
00024 */
00025 
00026 #include "schpriv.h"
00027 #include <ctype.h>
00028 #ifdef DOS_FILE_SYSTEM
00029 # include <windows.h>
00030 #endif
00031 #ifdef USE_C_SYSLOG
00032 # include <syslog.h>
00033 # include <stdarg.h>
00034 #endif
00035 
00036 #define mzVA_ARG(x, y) HIDE_FROM_XFORM(va_arg(x, y))
00037 #define TMP_CMARK_VALUE scheme_parameterization_key
00038 
00039 #ifndef INIT_SYSLOG_LEVEL
00040 # define INIT_SYSLOG_LEVEL 0
00041 #endif
00042 
00043 /* globals */
00044 scheme_console_printf_t scheme_console_printf;
00045 scheme_console_printf_t scheme_get_console_printf() { return scheme_console_printf; }
00046 Scheme_Exit_Proc scheme_exit;
00047 void scheme_set_exit(Scheme_Exit_Proc p) { scheme_exit = p; }
00048 
00049 void (*scheme_console_output)(char *str, long len);
00050 
00051 static int init_syslog_level = INIT_SYSLOG_LEVEL;
00052 static int init_stderr_level = SCHEME_LOG_ERROR;
00053 Scheme_Logger *scheme_main_logger;
00054 static void init_logger_config();
00055 
00056 /* readonly globals */
00057 const char *scheme_compile_stx_string = "compile";
00058 const char *scheme_expand_stx_string = "expand";
00059 const char *scheme_application_stx_string = "application";
00060 const char *scheme_set_stx_string = "set!";
00061 const char *scheme_var_ref_string = "#%variable-reference";
00062 const char *scheme_begin_stx_string = "begin";
00063 static Scheme_Object *fatal_symbol;
00064 static Scheme_Object *error_symbol; 
00065 static Scheme_Object *warning_symbol;
00066 static Scheme_Object *info_symbol;
00067 static Scheme_Object *debug_symbol;
00068 static Scheme_Object *arity_property;
00069 static Scheme_Object *def_err_val_proc;
00070 static Scheme_Object *def_error_esc_proc;
00071 static Scheme_Object *default_display_handler;
00072 static Scheme_Object *emergency_display_handler;
00073 Scheme_Object *scheme_def_exit_proc;
00074 Scheme_Object *scheme_raise_arity_error_proc;
00075 
00076 
00077 #ifdef MEMORY_COUNTING_ON
00078 long scheme_misc_count;
00079 #endif
00080 
00081 /* locals */
00082 static Scheme_Object *error(int argc, Scheme_Object *argv[]);
00083 static Scheme_Object *raise_user_error(int argc, Scheme_Object *argv[]);
00084 static Scheme_Object *raise_syntax_error(int argc, Scheme_Object *argv[]);
00085 static Scheme_Object *raise_type_error(int argc, Scheme_Object *argv[]);
00086 static Scheme_Object *raise_mismatch_error(int argc, Scheme_Object *argv[]);
00087 static Scheme_Object *raise_arity_error(int argc, Scheme_Object *argv[]);
00088 static Scheme_Object *error_escape_handler(int, Scheme_Object *[]);
00089 static Scheme_Object *error_display_handler(int, Scheme_Object *[]);
00090 static Scheme_Object *error_value_string_handler(int, Scheme_Object *[]);
00091 static Scheme_Object *exit_handler(int, Scheme_Object *[]);
00092 static Scheme_Object *error_print_width(int, Scheme_Object *[]);
00093 static Scheme_Object *error_print_context_length(int, Scheme_Object *[]);
00094 static Scheme_Object *error_print_srcloc(int, Scheme_Object *[]);
00095 static Scheme_Object *def_error_escape_proc(int, Scheme_Object *[]);
00096 static Scheme_Object *def_error_display_proc(int, Scheme_Object *[]);
00097 static Scheme_Object *emergency_error_display_proc(int, Scheme_Object *[]);
00098 static Scheme_Object *def_error_value_string_proc(int, Scheme_Object *[]);
00099 static Scheme_Object *def_exit_handler_proc(int, Scheme_Object *[]);
00100 
00101 static Scheme_Object *log_message(int argc, Scheme_Object *argv[]);
00102 static Scheme_Object *log_level_p(int argc, Scheme_Object *argv[]);
00103 static Scheme_Object *make_logger(int argc, Scheme_Object *argv[]);
00104 static Scheme_Object *logger_p(int argc, Scheme_Object *argv[]);
00105 static Scheme_Object *current_logger(int argc, Scheme_Object *argv[]);
00106 static Scheme_Object *logger_name(int argc, Scheme_Object *argv[]);
00107 static Scheme_Object *make_log_reader(int argc, Scheme_Object *argv[]);
00108 static Scheme_Object *log_reader_p(int argc, Scheme_Object *argv[]);
00109 static int log_reader_get(Scheme_Object *ch, Scheme_Schedule_Info *sinfo);
00110 
00111 static Scheme_Object *do_raise(Scheme_Object *arg, int need_debug, int barrier);
00112 static Scheme_Object *nested_exn_handler(void *old_exn, int argc, Scheme_Object *argv[]);
00113 
00114 static Scheme_Logger *make_a_logger(Scheme_Logger *parent, Scheme_Object *name);
00115 static void update_want_level(Scheme_Logger *logger);
00116 
00117 static Scheme_Object *check_arity_property_value_ok(int argc, Scheme_Object *argv[]);
00118 
00119 static char *init_buf(long *len, long *blen);
00120 void scheme_set_logging(int syslog_level, int stderr_level)
00121 {
00122   if (syslog_level > -1)
00123     init_syslog_level = syslog_level;
00124   if (stderr_level > -1)
00125     init_stderr_level = stderr_level;
00126 }
00127 
00128 typedef struct {
00129   int args;
00130   Scheme_Object *type;
00131   Scheme_Object **names;
00132   int count;
00133   Scheme_Object *exptime;
00134   int super_pos;
00135 } exn_rec;
00136 
00137 #define _MZEXN_TABLE
00138 #include "schexn.h"
00139 #undef _MZEXN_TABLE
00140 
00141 static void default_printf(char *msg, ...)
00142 {
00143   GC_CAN_IGNORE va_list args;
00144   HIDE_FROM_XFORM(va_start(args, msg));
00145   vfprintf(stderr, msg, args);
00146   HIDE_FROM_XFORM(va_end(args));
00147   fflush(stderr);
00148 }
00149 
00150 static void default_output(char *s, long len)
00151 {
00152   fwrite(s, len, 1, stderr);
00153   fflush(stderr);
00154 }
00155 
00156 Scheme_Config *scheme_init_error_escape_proc(Scheme_Config *config)
00157 {
00158   if (!def_error_esc_proc) {
00159     REGISTER_SO(def_error_esc_proc);
00160     def_error_esc_proc =
00161       scheme_make_prim_w_arity(def_error_escape_proc,
00162                             "default-error-escape-handler",
00163                             0, 0);
00164   }
00165 
00166   if (config)
00167     return scheme_extend_config(config, MZCONFIG_ERROR_ESCAPE_HANDLER, def_error_esc_proc);
00168   else {
00169     scheme_set_root_param(MZCONFIG_ERROR_ESCAPE_HANDLER, def_error_esc_proc);
00170     return NULL;
00171   }
00172 }
00173 
00174 /*
00175   Recognized by scheme_[v]sprintf:
00176 
00177   %c = unicode char
00178   %d = int
00179   %ld = long int
00180   %o = int, octal
00181   %f = double
00182   %% = percent
00183 
00184   %s = string
00185   %5 = mzchar string
00186   %S = Scheme symbol
00187   %t = string with size
00188   %u = mzchar string with size
00189   %T = Scheme string
00190   %q = truncated-to-256 string
00191   %Q = truncated-to-256 Scheme string
00192   %V = scheme_value
00193   %D = scheme value to display
00194   %_ = skip
00195 
00196   %L = line number, -1 means no line
00197   %e = error number for strerror()
00198   %E = error number for platform-specific error string
00199   %Z = potential platform-specific error number; additional char*
00200        is either NULL or a specific error message
00201   %N = boolean then error number like %E (if boolean is 0)
00202        or error number for scheme_hostname_error()
00203 */
00204 
00205 static long sch_vsprintf(char *s, long maxlen, const char *msg, va_list args, char **_s)
00206 /* NULL for s means allocate the buffer here (and return in (_s), but this function 
00207    doesn't allocate before extracting arguments from the stack. */
00208 {
00209   long i, j;
00210   char buf[100];
00211 
00212   /* Since we might malloc, move all pointers into a local array for
00213      the sake of precise GC. We have to do numbers, too, for
00214      consistency. */
00215 
00216   int pp = 0, ip = 0, dp = 0;
00217   void *ptrs[25];
00218   long ints[25];
00219   double dbls[25];
00220 
00221   for (j = 0; msg[j]; j++) {
00222     if (msg[j] == '%') {
00223       int type;
00224 
00225       j++;
00226       type = msg[j];
00227 
00228       switch (type) {
00229       case 'c':
00230        ints[ip++] = mzVA_ARG(args, int);
00231        break;
00232       case 'd':
00233       case 'o':
00234        ints[ip++] = mzVA_ARG(args, int);
00235        break;
00236       case 'l':
00237        ints[ip++] = mzVA_ARG(args, long);
00238        break;
00239       case 'f':
00240        dbls[dp++] = mzVA_ARG(args, double);
00241        break;
00242       case 'L':
00243        ints[ip++] = mzVA_ARG(args, long);
00244        break;
00245       case 'e':
00246       case 'E':
00247        ints[ip++] = mzVA_ARG(args, int);
00248        break;
00249       case 'N':
00250        ints[ip++] = mzVA_ARG(args, int);
00251        ints[ip++] = mzVA_ARG(args, int);
00252        break;
00253       case 'Z':
00254        ints[ip++] = mzVA_ARG(args, int);
00255        ptrs[pp++] = mzVA_ARG(args, char*);
00256        break;
00257       case 'S':
00258       case 'V':
00259       case 'D':
00260       case 'T':
00261       case 'Q':
00262       case '_':
00263        ptrs[pp++] = mzVA_ARG(args, Scheme_Object*);
00264        break;
00265       default:
00266        ptrs[pp++] = mzVA_ARG(args, char*);
00267        if ((type == 't') || (type == 'u')) {
00268          ints[ip++] = mzVA_ARG(args, long);
00269        }
00270       }
00271     }
00272   }
00273   pp = 0;
00274   ip = 0;
00275   dp = 0;
00276 
00277   if (!s) {
00278     s = init_buf(NULL, &maxlen);
00279     *_s = s;
00280   }
00281 
00282   --maxlen;
00283 
00284   i = j = 0;
00285   while ((i < maxlen) && msg[j]) {
00286     if (msg[j] == '%') {
00287       int type;
00288 
00289       j++;
00290       type = msg[j++];
00291 
00292       if (type == '%')
00293        s[i++] = '%';
00294       else {
00295        const char *t;
00296        int tlen;
00297        int dots = 0;
00298 
00299        switch (type) {
00300        case 'c':
00301          {
00302            int c;
00303            c = ints[ip++];
00304            if (c < 128) {
00305              buf[0] = c;
00306              tlen = 1;
00307            } else {
00308              mzchar mc;
00309              tlen = scheme_utf8_encode_all(&mc, 1, (unsigned char *)buf);
00310              c = (int)mc;
00311            }
00312            t = buf;
00313          }
00314          break;
00315        case 'd':
00316          {
00317            int d;
00318            d = ints[ip++];
00319            sprintf(buf, "%d", d);
00320            t = buf;
00321            tlen = strlen(t);
00322          }
00323          break;
00324        case 'o':
00325          {
00326            int d;
00327            d = ints[ip++];
00328            sprintf(buf, "%o", d);
00329            t = buf;
00330            tlen = strlen(t);
00331          }
00332          break;
00333        case 'l':
00334          {
00335            long d;
00336            j++;
00337            d = ints[ip++];
00338            sprintf(buf, "%ld", d);
00339            t = buf;
00340            tlen = strlen(t);
00341          }
00342          break;
00343        case 'f':
00344          {
00345            double f;
00346            j++;
00347            f = dbls[dp++];
00348            sprintf(buf, "%f", f);
00349            t = buf;
00350            tlen = strlen(t);
00351          }
00352          break;
00353        case 'L':
00354          {
00355            long d;
00356            d = ints[ip++];
00357            if (d >= 0) {
00358              sprintf(buf, "%ld:", d);
00359              t = buf;
00360              tlen = strlen(t);
00361            } else {
00362              t = ":";
00363              tlen = 1;
00364            }
00365          }
00366          break;
00367        case 'e':
00368        case 'E':
00369        case 'Z':
00370        case 'N':
00371          {
00372            int en, he;
00373            char *es;
00374 
00375            if (type == 'N') {
00376              he = ints[ip++];
00377              type = 'E';
00378            } else
00379              he = 0;
00380 
00381            en = ints[ip++];
00382 
00383            if (type == 'Z')
00384              es = ptrs[pp++];
00385            else
00386              es = NULL;
00387 
00388            if (he)
00389              es = (char *)scheme_hostname_error(en);
00390 
00391            if (en || es) {
00392 #ifdef NO_STRERROR_AVAILABLE
00393              if (!es)
00394               es = "Unknown error";
00395 #else
00396 # ifdef DOS_FILE_SYSTEM
00397              char mbuf[256];
00398              if ((type != 'e') && !es) {
00399               if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, NULL,
00400                               en, MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
00401                               mbuf, 255, NULL)) {
00402                 int i;
00403                 es = mbuf;
00404                 /* Remove newlines: */
00405                 for (i = strlen(es) - 1; i > 0; i--) {
00406                   if (isspace(es[i]))
00407                     es[i] = 0;
00408                   else
00409                     break;
00410                 }
00411               }
00412              }
00413 # endif
00414              if (!es)
00415               es = strerror(en);
00416 #endif
00417              tlen = strlen(es) + 24;
00418              t = (const char *)scheme_malloc_atomic(tlen);
00419              sprintf((char *)t, "%s; errno=%d", es, en);
00420              tlen = strlen(t);
00421            } else {
00422              t = "errno=?";
00423              tlen = 7;
00424            }
00425 
00426          }
00427          break;
00428        case 'S':
00429          {
00430            Scheme_Object *sym;
00431            sym = (Scheme_Object *)ptrs[pp++];
00432            t = scheme_symbol_name_and_size(sym, (unsigned int *)&tlen, 0);
00433          }
00434          break;
00435        case 'V':
00436          {
00437            Scheme_Object *o;
00438            o = (Scheme_Object *)ptrs[pp++];
00439            t = scheme_make_provided_string(o, 1, &tlen);
00440          }
00441          break;
00442        case 'D':
00443          {
00444            Scheme_Object *o;
00445             long dlen;
00446            o = (Scheme_Object *)ptrs[pp++];
00447            t = scheme_display_to_string(o, &dlen);
00448             tlen = dlen;
00449          }
00450          break;
00451         case '_':
00452           {
00453             pp++;
00454             t = "";
00455             tlen = 0;
00456           }
00457           break;
00458        case 'T':
00459        case 'Q':
00460          {
00461            Scheme_Object *str;
00462            str = (Scheme_Object *)ptrs[pp++];
00463            if (SCHEME_CHAR_STRINGP(str))
00464              str = scheme_char_string_to_byte_string(str);
00465            t = SCHEME_BYTE_STR_VAL(str);
00466            tlen = SCHEME_BYTE_STRLEN_VAL(str);
00467          }
00468          break;
00469        case 'u':
00470        case '5':
00471          {
00472            mzchar *u;
00473            long ltlen;
00474            u = (mzchar *)ptrs[pp++];
00475            if (type == 'u') {
00476              tlen = ints[ip++];
00477              if (tlen < 0)
00478               tlen = scheme_char_strlen(u);
00479            } else {
00480              tlen = scheme_char_strlen(u);
00481            }
00482            t = scheme_utf8_encode_to_buffer_len(u, tlen, NULL, 0, &ltlen);
00483            tlen = ltlen;
00484          }
00485          break;
00486        default:
00487          {
00488            t = (char *)ptrs[pp++];
00489            if (type == 't') {
00490              tlen = ints[ip++];
00491              if (tlen < 0)
00492               tlen = strlen(t);
00493            } else {
00494              tlen = strlen(t);
00495            }
00496          }
00497          break;
00498        }
00499 
00500        if ((type == 'q') || (type == 'Q')) {
00501          if (tlen > 256) {
00502            tlen = 250;
00503            dots = 1;
00504          }
00505        }
00506 
00507        while (tlen && i < maxlen) {
00508          s[i++] = *t;
00509          t = t XFORM_OK_PLUS 1;
00510          tlen--;
00511        }
00512 
00513        if (dots) {
00514          /* FIXME: avoiding truncating in the middle of a UTF-8 encoding */
00515          if (i < maxlen - 3) {
00516            s[i++] = '.';
00517            s[i++] = '.';
00518            s[i++] = '.';
00519          }
00520        }
00521       }
00522     } else {
00523       s[i++] = msg[j++];
00524     }
00525   }
00526 
00527   s[i] = 0;
00528 
00529   return i;
00530 }
00531 
00532 static long scheme_sprintf(char *s, long maxlen, const char *msg, ...)
00533 {
00534   long len;
00535   GC_CAN_IGNORE va_list args;
00536 
00537   HIDE_FROM_XFORM(va_start(args, msg));
00538   len = sch_vsprintf(s, maxlen, msg, args, NULL);
00539   HIDE_FROM_XFORM(va_end(args));
00540 
00541   return len;
00542 }
00543 
00544 void scheme_init_error(Scheme_Env *env)
00545 {
00546   if (!scheme_console_printf)
00547     scheme_console_printf = default_printf;
00548   if (!scheme_console_output)
00549     scheme_console_output = default_output;
00550 
00551   REGISTER_SO(scheme_raise_arity_error_proc);
00552 
00553   /* errors */
00554   GLOBAL_NONCM_PRIM("error",                      error,                 1, -1, env);
00555   GLOBAL_NONCM_PRIM("raise-user-error",           raise_user_error,      1, -1, env);
00556   GLOBAL_NONCM_PRIM("raise-syntax-error",         raise_syntax_error,    2,  5, env);
00557   GLOBAL_NONCM_PRIM("raise-type-error",           raise_type_error,      3, -1, env);
00558   GLOBAL_NONCM_PRIM("raise-mismatch-error",       raise_mismatch_error,  3,  3, env);
00559 
00560   scheme_raise_arity_error_proc =                  scheme_make_noncm_prim(raise_arity_error, "raise-arity-error", 2, -1);
00561   scheme_add_global_constant("raise-arity-error",  scheme_raise_arity_error_proc, env);
00562 
00563   GLOBAL_PARAMETER("error-display-handler",       error_display_handler,      MZCONFIG_ERROR_DISPLAY_HANDLER,       env);
00564   GLOBAL_PARAMETER("error-value->string-handler", error_value_string_handler, MZCONFIG_ERROR_PRINT_VALUE_HANDLER,   env);
00565   GLOBAL_PARAMETER("error-escape-handler",        error_escape_handler,       MZCONFIG_ERROR_ESCAPE_HANDLER,        env);
00566   GLOBAL_PARAMETER("exit-handler",                exit_handler,               MZCONFIG_EXIT_HANDLER,                env);
00567   GLOBAL_PARAMETER("error-print-width",           error_print_width,          MZCONFIG_ERROR_PRINT_WIDTH,           env);
00568   GLOBAL_PARAMETER("error-print-context-length",  error_print_context_length, MZCONFIG_ERROR_PRINT_CONTEXT_LENGTH,  env);
00569   GLOBAL_PARAMETER("error-print-source-location", error_print_srcloc,         MZCONFIG_ERROR_PRINT_SRCLOC,          env);
00570 
00571   /* logging */
00572   GLOBAL_NONCM_PRIM("exit",              scheme_do_exit,  0, 1, env);
00573   GLOBAL_NONCM_PRIM("log-level?",        log_level_p,     2, 2, env);
00574   GLOBAL_NONCM_PRIM("make-logger",       make_logger,     0, 2, env);
00575   GLOBAL_NONCM_PRIM("make-log-receiver", make_log_reader, 2, 2, env);
00576 
00577   GLOBAL_PRIM_W_ARITY("log-message",    log_message,   4, 4, env);
00578   GLOBAL_FOLDING_PRIM("logger?",        logger_p,      1, 1, 1, env);
00579   GLOBAL_FOLDING_PRIM("logger-name",    logger_name,   1, 1, 1, env);
00580   GLOBAL_FOLDING_PRIM("log-receiver?",  log_reader_p,  1, 1, 1, env);
00581 
00582   GLOBAL_PARAMETER("current-logger",    current_logger, MZCONFIG_LOGGER, env);
00583 
00584   scheme_add_evt(scheme_log_reader_type, (Scheme_Ready_Fun)log_reader_get, NULL, NULL, 1);
00585 
00586   REGISTER_SO(scheme_def_exit_proc);
00587   scheme_def_exit_proc = scheme_make_prim_w_arity(def_exit_handler_proc, "default-exit-handler", 1, 1);
00588 
00589   REGISTER_SO(def_err_val_proc);
00590   def_err_val_proc = scheme_make_prim_w_arity(def_error_value_string_proc, "default-error-value->string-handler", 2, 2);
00591 
00592   REGISTER_SO(fatal_symbol);
00593   REGISTER_SO(error_symbol);
00594   REGISTER_SO(warning_symbol);
00595   REGISTER_SO(info_symbol);
00596   REGISTER_SO(debug_symbol);
00597   fatal_symbol    = scheme_intern_symbol("fatal");
00598   error_symbol    = scheme_intern_symbol("error");
00599   warning_symbol  = scheme_intern_symbol("warning");
00600   info_symbol     = scheme_intern_symbol("info");
00601   debug_symbol    = scheme_intern_symbol("debug");
00602 
00603   {
00604     REGISTER_SO(scheme_main_logger);
00605     scheme_main_logger = make_a_logger(NULL, NULL);
00606     scheme_main_logger->syslog_level = init_syslog_level;
00607     scheme_main_logger->stderr_level = init_stderr_level;
00608   }
00609   init_logger_config();
00610 
00611   REGISTER_SO(arity_property);
00612   {
00613     Scheme_Object *guard;
00614     guard = scheme_make_prim_w_arity(check_arity_property_value_ok, "guard-for-prop:arity-string", 2, 2);
00615     arity_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("arity-string"), guard);
00616   }
00617                                                             
00618   scheme_add_global_constant("prop:arity-string", arity_property, env);
00619 
00620   scheme_init_error_config();
00621 }
00622 
00623 static void init_logger_config()
00624 {
00625   scheme_set_root_param(MZCONFIG_LOGGER, (Scheme_Object *)scheme_main_logger);
00626 }
00627 
00628 void scheme_init_error_config(void)
00629 {
00630   init_logger_config();
00631 
00632   scheme_set_root_param(MZCONFIG_EXIT_HANDLER, scheme_def_exit_proc);
00633   
00634   REGISTER_SO(default_display_handler);
00635   REGISTER_SO(emergency_display_handler);
00636 
00637   default_display_handler = scheme_make_prim_w_arity(def_error_display_proc, "default-error-display-handler", 2, 2);
00638   emergency_display_handler = scheme_make_prim_w_arity(emergency_error_display_proc, "emergency-error-display-handler", 2, 2);
00639   
00640   scheme_set_root_param(MZCONFIG_ERROR_DISPLAY_HANDLER, default_display_handler);
00641   scheme_set_root_param(MZCONFIG_ERROR_PRINT_VALUE_HANDLER, def_err_val_proc);
00642 }
00643 
00644 static void
00645 scheme_inescapeable_error(const char *a, const char *b)
00646 {
00647   int al, bl;
00648   char *t;
00649 
00650   al = strlen(a);
00651   bl = strlen(b);
00652   t = scheme_malloc_atomic(al + bl + 2);
00653   memcpy(t, a, al);
00654   memcpy(t + al, b, bl);
00655   t[al + bl] = '\n';
00656   t[al + bl + 1] = 0;
00657 
00658   scheme_console_output(t, al + bl + 1);
00659 }
00660 
00661 static void
00662 call_error(char *buffer, int len, Scheme_Object *exn)
00663 {
00664   if (scheme_current_thread->constant_folding) {
00665     if (SCHEME_TRUEP(scheme_current_thread->constant_folding))
00666       scheme_log(NULL,
00667                  SCHEME_LOG_WARNING,
00668                  0,
00669                  "optimizer constant-fold attempt failed%s: %s",
00670                  scheme_optimize_context_to_string(scheme_current_thread->constant_folding),
00671                  buffer);
00672     if (SCHEME_STRUCTP(exn)
00673         && scheme_is_struct_instance(exn_table[MZEXN_BREAK].type, exn)) {
00674       /* remember to re-raise exception */
00675       scheme_current_thread->reading_delayed = exn;
00676     }
00677     scheme_longjmp(scheme_error_buf, 1);
00678   } else if (scheme_current_thread->reading_delayed) {
00679     scheme_current_thread->reading_delayed = exn;
00680     scheme_longjmp(scheme_error_buf, 1);
00681   } else {
00682     mz_jmp_buf savebuf;
00683     Scheme_Object *p[2], *display_handler, *escape_handler, *v;
00684     Scheme_Config *config, *orig_config;
00685     Scheme_Cont_Frame_Data cframe, cframe2;
00686 
00687     /* For last resort: */
00688     memcpy((void *)&savebuf, &scheme_error_buf, sizeof(mz_jmp_buf));
00689 
00690     orig_config = scheme_current_config();
00691     display_handler = scheme_get_param(orig_config, MZCONFIG_ERROR_DISPLAY_HANDLER);
00692     escape_handler = scheme_get_param(orig_config, MZCONFIG_ERROR_ESCAPE_HANDLER);
00693     
00694     v = scheme_make_byte_string_without_copying("error display handler");
00695     v = scheme_make_closed_prim_w_arity(nested_exn_handler,
00696                                    scheme_make_pair(v, exn),
00697                                    "nested-exception-handler", 
00698                                    1, 1);
00699 
00700     config = orig_config;
00701     if (SAME_OBJ(display_handler, default_display_handler))
00702       config = scheme_extend_config(config,
00703                                 MZCONFIG_ERROR_DISPLAY_HANDLER,
00704                                 emergency_display_handler);
00705     else
00706       config = scheme_extend_config(config,
00707                                 MZCONFIG_ERROR_DISPLAY_HANDLER,
00708                                 default_display_handler);
00709     
00710     scheme_push_continuation_frame(&cframe);
00711     scheme_install_config(config);
00712     scheme_set_cont_mark(scheme_exn_handler_key, v);
00713     scheme_push_break_enable(&cframe2, 0, 0);
00714 
00715     p[0] = scheme_make_immutable_sized_utf8_string(buffer, len);
00716     p[1] = exn;
00717     scheme_apply_multi(display_handler, 2, p);
00718 
00719     v = scheme_make_byte_string_without_copying("error escape handler");
00720     v = scheme_make_closed_prim_w_arity(nested_exn_handler,
00721                                    scheme_make_pair(v, exn),
00722                                    "nested-exception-handler", 
00723                                    1, 1);
00724     
00725     config = scheme_extend_config(config,
00726                               MZCONFIG_ERROR_DISPLAY_HANDLER,
00727                               default_display_handler);
00728     config = scheme_extend_config(config,
00729                               MZCONFIG_ERROR_ESCAPE_HANDLER,
00730                               def_error_esc_proc);
00731         
00732     scheme_pop_break_enable(&cframe2, 0);
00733     scheme_pop_continuation_frame(&cframe);
00734 
00735     scheme_push_continuation_frame(&cframe);
00736     scheme_set_cont_mark(scheme_exn_handler_key, v);
00737     scheme_install_config(config);
00738     scheme_push_break_enable(&cframe2, 0, 0);
00739 
00740     /* Typically jumps out of here */
00741     scheme_apply_multi(escape_handler, 0, NULL);
00742 
00743     scheme_pop_break_enable(&cframe2, 0);
00744     scheme_pop_continuation_frame(&cframe);
00745 
00746     /* Uh-oh; record the error and fall back to the default escaper */
00747     scheme_inescapeable_error("error escape handler did not escape; calling the default error escape handler", "");
00748     scheme_longjmp(savebuf, 1); /* force an exit */
00749   }
00750 }
00751 
00752 static long get_print_width(void)
00753 {
00754   long print_width;
00755   Scheme_Object *w;
00756 
00757   w = scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PRINT_WIDTH);
00758   if (SCHEME_INTP(w))
00759     print_width = SCHEME_INT_VAL(w);
00760   else if (SCHEME_BIGNUMP(w))
00761     print_width = 0x7FFFFFFF;
00762   else
00763     print_width = 10000;
00764 
00765   return print_width;
00766 }
00767 
00768 static char *init_buf(long *len, long *_size)
00769 {
00770   long size, print_width;
00771 
00772   print_width = get_print_width();
00773 
00774   if (len)
00775     *len = print_width;
00776 
00777   size = (3 * scheme_max_found_symbol_name + 500 + 2 * print_width);
00778   if (_size)
00779     *_size = size;
00780 
00781   return (char *)scheme_malloc_atomic(size);
00782 }
00783 
00784 void
00785 scheme_signal_error (const char *msg, ...)
00786 {
00787   GC_CAN_IGNORE va_list args;
00788   char *buffer;
00789   long len;
00790 
00791   HIDE_FROM_XFORM(va_start(args, msg));
00792   len = sch_vsprintf(NULL, 0, msg, args, &buffer);
00793   HIDE_FROM_XFORM(va_end(args));
00794 
00795   if (scheme_current_thread->current_local_env) {
00796     char *s2 = " [during expansion]";
00797     strcpy(buffer + len, s2);
00798     len += strlen(s2);
00799   }
00800 
00801   buffer[len] = 0;
00802 
00803   if (scheme_starting_up) {
00804     buffer[len++] = '\n';
00805     buffer[len] = 0;
00806     scheme_console_output(buffer, len);
00807     exit(0);
00808   }
00809 
00810 #ifndef SCHEME_NO_EXN
00811   scheme_raise_exn(MZEXN_FAIL, "%t", buffer, len);
00812 #else
00813   call_error(buffer, len, scheme_false);
00814 #endif
00815 }
00816 
00817 void scheme_warning(char *msg, ...)
00818 {
00819   GC_CAN_IGNORE va_list args;
00820   char *buffer;
00821   long len;
00822 
00823   HIDE_FROM_XFORM(va_start(args, msg));
00824   len = sch_vsprintf(NULL, 0, msg, args, &buffer);
00825   HIDE_FROM_XFORM(va_end(args));
00826 
00827   buffer[len++] = '\n';
00828   buffer[len] = 0;
00829 
00830   scheme_write_byte_string(buffer, len,
00831                         scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PORT));
00832 }
00833 
00834 void scheme_log(Scheme_Logger *logger, int level, int flags,
00835                 char *msg, ...)
00836 {
00837   GC_CAN_IGNORE va_list args;
00838   char *buffer;
00839   long len;
00840 
00841   if (logger) {
00842     if (logger->local_timestamp == *logger->timestamp)
00843       if (logger->want_level < level)
00844         return;
00845   }
00846 
00847   HIDE_FROM_XFORM(va_start(args, msg));
00848   len = sch_vsprintf(NULL, 0, msg, args, &buffer);
00849   HIDE_FROM_XFORM(va_end(args));
00850 
00851   buffer[len] = 0;
00852 
00853   scheme_log_message(logger, level, buffer, len, NULL);
00854 }
00855 
00856 int scheme_log_level_p(Scheme_Logger *logger, int level)
00857 {
00858   if (!logger) {
00859     Scheme_Config *config;
00860     config = scheme_current_config();
00861     logger = (Scheme_Logger *)scheme_get_param(config, MZCONFIG_LOGGER);
00862   }
00863 
00864   if (logger->local_timestamp < *logger->timestamp)
00865     update_want_level(logger);
00866 
00867   return (logger->want_level >= level);
00868 }
00869 
00870 static char *error_write_to_string_w_max(Scheme_Object *v, int len, int *lenout)
00871 {
00872   Scheme_Object *o, *args[2];
00873 
00874   o = scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PRINT_VALUE_HANDLER);
00875 
00876   if ((SAME_OBJ(o, def_err_val_proc)
00877        && SAME_OBJ(scheme_get_param(scheme_current_config(), MZCONFIG_PORT_PRINT_HANDLER),
00878                  scheme_default_global_print_handler))) {
00879     long l;
00880     char *s;
00881     s = scheme_print_to_string_w_max(v, &l, len);
00882     if (lenout)
00883       *lenout = l;
00884     return s;
00885   } else {
00886     Scheme_Config *config;
00887     Scheme_Cont_Frame_Data cframe, cframe2;
00888 
00889     args[0] = v;
00890     args[1] = scheme_make_integer(len);
00891 
00892     config = scheme_extend_config(scheme_current_config(),
00893                               MZCONFIG_ERROR_PRINT_VALUE_HANDLER,
00894                               def_err_val_proc);
00895     config = scheme_extend_config(config,
00896                               MZCONFIG_PRINT_UNREADABLE,
00897                               scheme_true);
00898 
00899     scheme_push_continuation_frame(&cframe);
00900     scheme_install_config(config);
00901     scheme_push_break_enable(&cframe2, 0, 0);
00902 
00903     o = _scheme_apply(o, 2, args);
00904 
00905     scheme_pop_break_enable(&cframe2, 0);
00906     scheme_pop_continuation_frame(&cframe);
00907 
00908     if (SCHEME_CHAR_STRINGP(o)) {
00909       o = scheme_char_string_to_byte_string(o);
00910     }
00911 
00912     if (SCHEME_BYTE_STRINGP(o)) {
00913       char *s = SCHEME_BYTE_STR_VAL(o);
00914       if (SCHEME_BYTE_STRTAG_VAL(o) > len) {
00915        char *naya;
00916        naya = scheme_malloc_atomic(len + 1);
00917        memcpy(naya, s, len);
00918        s[len] = 0;
00919        if (lenout)
00920          *lenout = len;
00921       } else if (lenout)
00922        *lenout = SCHEME_BYTE_STRTAG_VAL(o);
00923       return s;
00924     } else {
00925       if (lenout)
00926        *lenout = 3;
00927       return "...";
00928     }
00929   }
00930 }
00931 
00932 static Scheme_Object *check_arity_property_value_ok(int argc, Scheme_Object *argv[])
00933 {
00934   if (!scheme_check_proc_arity(NULL, 1, 0, 1, argv))
00935     scheme_arg_mismatch("guard-for-prop:arity-string",
00936                         "property value is not a procedure (arity 1): ",
00937                         argv[0]);
00938   return argv[0];
00939 }
00940 
00941 static char *make_arity_expect_string(const char *name, int namelen,
00942                                   int minc, int maxc,
00943                                   int argc, Scheme_Object **argv,
00944                                   long *_len, int is_method)
00945 /* minc == -1 => name is really a case-lambda, native closure, or proc-struct.
00946    minc == -2 => use generic "no matching clause" message */
00947 {
00948   long len, pos, slen;
00949   int xargc, xminc, xmaxc;
00950   char *s, *arity_str = NULL;
00951   int arity_len = 0;
00952 
00953   s = init_buf(&len, &slen);
00954 
00955   if (!name)
00956     name = "#<procedure>";
00957 
00958   xargc = argc - (is_method ? 1 : 0);
00959   xminc = minc - (is_method ? 1 : 0);
00960   xmaxc = maxc - (is_method ? 1 : 0);
00961 
00962   if ((minc == -1) && SCHEME_PROC_STRUCTP((Scheme_Object *)name)) {
00963     Scheme_Object *arity_maker;
00964 
00965     while (1) {
00966       arity_maker = scheme_struct_type_property_ref(arity_property, (Scheme_Object *)name);
00967       if (arity_maker) {
00968         Scheme_Object *v, *a[1];
00969         a[0] = (Scheme_Object *)name;
00970         v = scheme_apply(arity_maker, 1, a);
00971         if (SCHEME_CHAR_STRINGP(v)) {
00972           v = scheme_char_string_to_byte_string(v);
00973           arity_str = SCHEME_BYTE_STR_VAL(v);
00974           arity_len = SCHEME_BYTE_STRLEN_VAL(v);
00975           if (arity_len > len)
00976             arity_len = len;
00977           name = scheme_get_proc_name((Scheme_Object *)name, &namelen, 1);
00978           if (!name) {
00979             name = "#<procedure>";
00980             namelen = strlen(name);
00981           }
00982           break;
00983         } else
00984           break;
00985       } else {
00986         Scheme_Object *v;
00987         int is_method;
00988         v = scheme_extract_struct_procedure((Scheme_Object *)name, -1, NULL, &is_method);
00989         if (!v || is_method || !SCHEME_PROC_STRUCTP(v))
00990           break;
00991         name = (const char *)v;
00992       }
00993       SCHEME_USE_FUEL(1);
00994     }
00995 
00996     if (!arity_str) {
00997       /* If the arity is something simple, we'll make a good error
00998          message. Otherwise, we'll just use the "no matching case"
00999          version. */
01000       Scheme_Object *arity;
01001       arity = scheme_arity((Scheme_Object *)name);
01002       if (SCHEME_INTP(arity)) {
01003         xminc = xmaxc = minc = maxc = SCHEME_INT_VAL(arity);
01004         name = scheme_get_proc_name((Scheme_Object *)name, &namelen, 1);
01005         if (!name) {
01006           name = "#<procedure>";
01007           namelen = strlen(name);
01008         }
01009       }
01010     }
01011   }
01012 
01013   if (arity_str) {
01014     pos = scheme_sprintf(s, slen, "%t: expects %t, given %d",
01015                       name, namelen, arity_str, arity_len, xargc);
01016   } else if (minc < 0) {
01017     const char *n;
01018     int nlen;
01019 
01020     if (minc == -2) {
01021       n = name;
01022       nlen = (namelen < 0 ? strlen(n) : namelen);
01023     } else
01024       n = scheme_get_proc_name((Scheme_Object *)name, &nlen, 1);
01025 
01026     if (!n) {
01027       n = "#<case-lambda-procedure>";
01028       nlen = strlen(n);
01029     }
01030 
01031     pos = scheme_sprintf(s, slen, "%t: no clause matching %d argument%s",
01032                       n, nlen,
01033                       xargc, xargc == 1 ? "" : "s");
01034   } else if (!maxc)
01035     pos = scheme_sprintf(s, slen, "%t: expects no arguments, given %d",
01036                       name, namelen, xargc);
01037   else if (maxc < 0)
01038     pos = scheme_sprintf(s, slen, "%t: expects at least %d argument%s, given %d",
01039                       name, namelen, xminc, (xminc == 1) ? "" : "s", xargc);
01040   else if (minc == maxc)
01041     pos = scheme_sprintf(s, slen, "%t: expects %d argument%s, given %d",
01042                       name, namelen, xminc, (xminc == 1) ? "" : "s", xargc);
01043   else
01044     pos = scheme_sprintf(s, slen, "%t: expects %d to %d arguments, given %d",
01045                       name, namelen, xminc, xmaxc, xargc);
01046 
01047   if (xargc && argv) {
01048     len /= xargc;
01049     if ((xargc < 50) && (len >= 3)) {
01050       int i;
01051 
01052       strcpy(s + pos, ":");
01053       pos++;
01054 
01055       for (i = (is_method ? 1 : 0); i < argc; i++) {
01056        int l;
01057        char *o;
01058        o = error_write_to_string_w_max(argv[i], len, &l);
01059        memcpy(s + pos, " ", 1);
01060        memcpy(s + pos + 1, o, l);
01061        pos += l + 1;
01062       }
01063 
01064       s[pos] = 0;
01065     }
01066   }
01067 
01068   *_len = pos;
01069 
01070   return s;
01071 }
01072 
01073 void scheme_wrong_count_m(const char *name, int minc, int maxc,
01074                        int argc, Scheme_Object **argv, int is_method)
01075 /* minc == -1 => name is really a proc.
01076    minc == -2 => use generic "no matching clause" message */
01077 {
01078   char *s;
01079   long len;
01080   Scheme_Thread *p = scheme_current_thread;
01081 
01082   if (argv == p->tail_buffer) {
01083     /* See calls in scheme_do_eval: */
01084     GC_CAN_IGNORE Scheme_Object **tb;
01085     p->tail_buffer = NULL; /* so args aren't zeroed */
01086     tb = MALLOC_N(Scheme_Object *, p->tail_buffer_size);
01087     p->tail_buffer = tb;
01088   }
01089 
01090   /* minc = 1 -> name is really a case-lambda or native proc */
01091 
01092   if (minc == -1) {
01093     /* Extract arity, check for is_method in case-lambda, etc. */
01094     if (SAME_TYPE(SCHEME_TYPE((Scheme_Object *)name), scheme_closure_type)) {
01095       Scheme_Closure_Data *data;
01096       data = SCHEME_COMPILED_CLOS_CODE((Scheme_Object *)name);
01097       name = scheme_get_proc_name((Scheme_Object *)name, NULL, 1);
01098       
01099       minc = data->num_params;
01100       if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) {
01101         minc -= 1;
01102         maxc = -1;
01103       } else
01104         maxc = minc;
01105     } else if (SAME_TYPE(SCHEME_TYPE((Scheme_Object *)name), scheme_case_closure_type)) {
01106       Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)name;
01107       if (cl->count) {
01108        Scheme_Closure_Data *data;
01109        data = (Scheme_Closure_Data *)SCHEME_COMPILED_CLOS_CODE(cl->array[0]);
01110        if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_IS_METHOD)
01111          is_method = 1;
01112       } else if (cl->name && SCHEME_BOXP(cl->name)) {
01113        /* See note in schpriv.h about the IS_METHOD hack */
01114        is_method = 1;
01115       }
01116 #ifdef MZ_USE_JIT
01117     } else if (SAME_TYPE(SCHEME_TYPE((Scheme_Object *)name), scheme_native_closure_type)) {
01118       Scheme_Object *pa;
01119       pa = scheme_get_native_arity((Scheme_Object *)name);
01120       if (SCHEME_BOXP(pa)) {
01121        pa = SCHEME_BOX_VAL(pa);
01122        is_method = 1;
01123       }
01124       if (SCHEME_INTP(pa)) {
01125        minc = SCHEME_INT_VAL(pa);
01126        if (minc < 0) {
01127          minc = (-minc) - 1;
01128          maxc = -1;
01129        } else
01130          maxc = minc;
01131        name = scheme_get_proc_name((Scheme_Object *)name, NULL, 1);
01132       } else if (SCHEME_STRUCTP(pa)) {
01133        /* This happens when a non-case-lambda is not yet JITted.
01134         It's an arity-at-least record. */
01135        pa = ((Scheme_Structure *)pa)->slots[0];
01136        minc = SCHEME_INT_VAL(pa);
01137        maxc = -1;
01138        name = scheme_get_proc_name((Scheme_Object *)name, NULL, 1);
01139       } else {
01140        /* complex; use "no matching case" msg */
01141       }
01142 #endif
01143     }
01144   }
01145 
01146   /* Watch out for impossible is_method claims: */
01147   if (!argc || !minc)
01148     is_method = 0;
01149 
01150   if (maxc > SCHEME_MAX_ARGS)
01151     maxc = -1;
01152 
01153   s = make_arity_expect_string(name, -1, minc, maxc, argc, argv, &len, is_method);
01154 
01155   scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY, "%t", s, len);
01156 }
01157 
01158 void scheme_wrong_count(const char *name, int minc, int maxc, int argc,
01159                      Scheme_Object **argv)
01160 {
01161   /* don't allocate here, in case rands == p->tail_buffer */
01162   scheme_wrong_count_m(name, minc, maxc, argc, argv, 0);
01163 }
01164 
01165 void scheme_case_lambda_wrong_count(const char *name,
01166                                 int argc, Scheme_Object **argv,
01167                                 int is_method,
01168                                 int count, ...)
01169 {
01170   char *s;
01171   long len;
01172 
01173   /* Watch out for impossible is_method claims: */
01174   if (!argc)
01175     is_method = 0;
01176 
01177   s = make_arity_expect_string(name, -1, -2, 0, argc, argv, &len, is_method);
01178 
01179   scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY, "%t", s, len);
01180 }
01181 
01182 char *scheme_make_arity_expect_string(Scheme_Object *proc,
01183                                   int argc, Scheme_Object **argv,
01184                                   long *_slen)
01185 {
01186   const char *name;
01187   int namelen = -1;
01188   int mina, maxa;
01189 
01190   if (SCHEME_PRIMP(proc)) {
01191     name = ((Scheme_Primitive_Proc *)proc)->name;
01192     mina = ((Scheme_Primitive_Proc *)proc)->mina;
01193     if (mina < 0) {
01194       /* set min1 to -2 to indicates cases */
01195       mina = -2;
01196       maxa = 0;
01197     } else {
01198       maxa = ((Scheme_Primitive_Proc *)proc)->mu.maxa;
01199       if (maxa > SCHEME_MAX_ARGS)
01200        maxa = -1;
01201     }
01202   } else if (SCHEME_CLSD_PRIMP(proc)) {
01203     name = ((Scheme_Closed_Primitive_Proc *)proc)->name;
01204     mina = ((Scheme_Closed_Primitive_Proc *)proc)->mina;
01205     maxa = ((Scheme_Closed_Primitive_Proc *)proc)->maxa;
01206   } else if (SAME_TYPE(SCHEME_TYPE(proc), scheme_case_closure_type)) {
01207     name = scheme_get_proc_name(proc, &namelen, 1);
01208     mina = -2;
01209     maxa = 0;
01210 #ifdef MZ_USE_JIT
01211   } else if (SAME_TYPE(SCHEME_TYPE((Scheme_Object *)proc), scheme_native_closure_type)) {
01212     Scheme_Object *pa;
01213     pa = scheme_get_native_arity((Scheme_Object *)proc);
01214     if (SCHEME_BOXP(pa)) {
01215       pa = SCHEME_BOX_VAL(pa);
01216     }
01217     if (SCHEME_INTP(pa)) {
01218       mina = SCHEME_INT_VAL(pa);
01219       if (mina < 0) {
01220        mina = (-mina) - 1;
01221        maxa = -1;
01222       } else
01223        maxa = mina;
01224     } else if (SCHEME_STRUCTP(pa)) {
01225       /* This happens when a non-case-lambda is not yet JITted.
01226         It's an arity-at-least record. */
01227       pa = ((Scheme_Structure *)pa)->slots[0];
01228       mina = SCHEME_INT_VAL(pa);
01229       maxa = -1;
01230     } else {
01231       /* complex; use "no matching case" msg */
01232       mina = -2;
01233       maxa = 0;
01234     }
01235     name = scheme_get_proc_name((Scheme_Object *)proc, &namelen, 1);
01236 #endif
01237   } else if (SCHEME_STRUCTP(proc)) {
01238     name = (const char *)proc;
01239     mina = -1;
01240     maxa = 0;
01241   } else {
01242     Scheme_Closure_Data *data;
01243 
01244     data = (Scheme_Closure_Data *)SCHEME_COMPILED_CLOS_CODE(proc);
01245     mina = maxa = data->num_params;
01246     if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) {
01247       --mina;
01248       maxa = -1;
01249     }
01250     name = scheme_get_proc_name(proc, &namelen, 1);
01251   }
01252 
01253   return make_arity_expect_string(name, namelen, mina, maxa, argc, argv, _slen, 0);
01254 }
01255 
01256 char *scheme_make_args_string(char *s, int which, int argc, Scheme_Object **argv, long *_olen)
01257 {
01258   char *other;
01259   long len;
01260   GC_CAN_IGNORE char *isres = "arguments";
01261 
01262   other = init_buf(&len, NULL);
01263 
01264   if (argc < 0) {
01265     isres = "results";
01266     argc = -argc;
01267   }
01268 
01269   len /= (argc - (((which >= 0) && (argc > 1)) ? 1 : 0));
01270   if ((argc < 50) && (len >= 3)) {
01271     int i, pos;
01272 
01273     sprintf(other, "; %s%s were:", s, isres);
01274     pos = strlen(other);
01275     for (i = 0; i < argc; i++) {
01276       if (i != which) {
01277        int l;
01278        char *o;
01279        o = error_write_to_string_w_max(argv[i], len, &l);
01280        memcpy(other + pos, " ", 1);
01281        memcpy(other + pos + 1, o, l);
01282        pos += l + 1;
01283       }
01284     }
01285     other[pos] = 0;
01286     if (_olen)
01287       *_olen = pos;
01288   } else {
01289     sprintf(other, "; given %d arguments total", argc);
01290     if (_olen)
01291       *_olen = strlen(other);
01292   }
01293 
01294   return other;
01295 }
01296 
01297 const char *scheme_number_suffix(int which)
01298 {
01299   static char *ending[] = {"st", "nd", "rd"};
01300 
01301   if (!which)
01302     return "th";
01303   --which;
01304 
01305   which = which % 100;
01306 
01307   return ((which < 10 || which >= 20)
01308          && ((which % 10) < 3)) ? ending[which % 10] : "th";
01309 }
01310 
01311 void scheme_wrong_type(const char *name, const char *expected,
01312                      int which, int argc,
01313                      Scheme_Object **argv)
01314 {
01315   Scheme_Object *o;
01316   char *s;
01317   int slen;
01318   int isres = 0;
01319   GC_CAN_IGNORE char *isress = "argument";
01320 
01321   o = argv[which < 0 ? 0 : which];
01322   if (argc < 0) {
01323     argc = -argc;
01324     isress = "result";
01325     isres = 1;
01326   }
01327 
01328   s = scheme_make_provided_string(o, 1, &slen);
01329 
01330   if ((which < 0) || (argc == 1))
01331     scheme_raise_exn(MZEXN_FAIL_CONTRACT,
01332                    "%s: expect%s %s of type <%s>; "
01333                    "given %t",
01334                    name, 
01335                    (which < 0) ? "ed" : "s",
01336                    isress, expected, s, slen);
01337   else {
01338     char *other;
01339     long olen;
01340 
01341     if ((which >= 0) && (argc > 1))
01342       other = scheme_make_args_string("other ", which,
01343                                   (isres ? -argc : argc),
01344                                   argv, &olen);
01345     else {
01346       other = "";
01347       olen = 0;
01348     }
01349 
01350     scheme_raise_exn(MZEXN_FAIL_CONTRACT,
01351                    "%s: expects type <%s> as %d%s %s, "
01352                    "given: %t%t",
01353                    name, expected, which + 1,
01354                    scheme_number_suffix(which + 1),
01355                    isress,
01356                    s, slen, other, olen);
01357   }
01358 }
01359 
01360 void scheme_wrong_field_type(Scheme_Object *c_name,
01361                           const char *expected,
01362                           Scheme_Object *o)
01363 {
01364   const char *s;
01365   char *s2;
01366   int l;
01367   Scheme_Object *a[1];
01368   a[0] = o;
01369   s = scheme_symbol_name(c_name);
01370   l = strlen(s);
01371   s2 = (char *)scheme_malloc_atomic(l + 6);
01372   memcpy(s2, "make-", 5);
01373   memcpy(s2 + 5, s, l + 1);
01374   scheme_wrong_type(s2, expected, -1, 0, a);
01375 }
01376 
01377 void scheme_arg_mismatch(const char *name, const char *msg, Scheme_Object *o)
01378 {
01379   char *s;
01380   int slen;
01381 
01382   if (o)
01383     s = scheme_make_provided_string(o, 1, &slen);
01384   else {
01385     s = "";
01386     slen = 0;
01387   }
01388 
01389   scheme_raise_exn(MZEXN_FAIL_CONTRACT,
01390                  "%s: %s%t",
01391                  name, msg, s, slen);
01392 }
01393 
01394 #define MZERR_MAX_SRC_LEN 100
01395 
01396 static char *make_srcloc_string(Scheme_Stx_Srcloc *srcloc, long *len)
01397 {
01398   long line, col;
01399   Scheme_Object *src;
01400   char *srcstr, *result;
01401   long srclen, rlen;
01402 
01403   if (!srcloc->src || (SCHEME_FALSEP(srcloc->src) && (srcloc->pos < 0))) {
01404     if (len) *len = 0;
01405     return NULL;
01406   }
01407 
01408   line = srcloc->line;
01409   col = srcloc->col;
01410   if (col < 0)
01411     col = srcloc->pos;
01412 
01413   src = srcloc->src;
01414 
01415   if (src && SCHEME_PATHP(src)) {
01416     /* Strip off prefix matching the current directory: */
01417     src = scheme_remove_current_directory_prefix(src);
01418 
01419     /* Truncate from the front, to get the interesting part of paths: */
01420     srclen = SCHEME_BYTE_STRLEN_VAL(src);
01421     if (srclen > MZERR_MAX_SRC_LEN) {
01422       srcstr = scheme_malloc_atomic(MZERR_MAX_SRC_LEN);
01423       memcpy(srcstr, SCHEME_BYTE_STR_VAL(src) + (srclen - MZERR_MAX_SRC_LEN),
01424             MZERR_MAX_SRC_LEN);
01425       srcstr[0] = '.';
01426       srcstr[1] = '.';
01427       srcstr[2] = '.';
01428       srclen = MZERR_MAX_SRC_LEN;
01429     } else
01430       srcstr = SCHEME_BYTE_STR_VAL(src);
01431   } else
01432     srcstr = scheme_display_to_string_w_max(src, &srclen, MZERR_MAX_SRC_LEN);
01433 
01434   result = (char *)scheme_malloc_atomic(srclen + 15);
01435 
01436   if (col >= 0) {
01437     rlen = scheme_sprintf(result, srclen + 15, "%t:%L%ld: ",
01438                        srcstr, srclen, line, col-1);
01439   } else {
01440     rlen = scheme_sprintf(result, srclen + 15, "%t::: ",
01441                        srcstr, srclen);
01442   }
01443 
01444   if (len) *len = rlen;
01445   return result;
01446 }
01447 
01448 void scheme_read_err(Scheme_Object *port,
01449                    Scheme_Object *stxsrc,
01450                    long line, long col, long pos, long span,
01451                    int gotc, Scheme_Object *indentation,
01452                    const char *detail, ...)
01453 {
01454   GC_CAN_IGNORE va_list args;
01455   char *s, *ls, lbuf[30], *fn, *suggests;
01456   long slen, fnlen;
01457   int show_loc;
01458   Scheme_Object *loc;
01459 
01460   HIDE_FROM_XFORM(va_start(args, detail));
01461   slen = sch_vsprintf(NULL, 0, detail, args, &s);
01462   HIDE_FROM_XFORM(va_end(args));
01463 
01464   ls = "";
01465   fnlen = 0;
01466 
01467   show_loc = SCHEME_TRUEP(scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PRINT_SRCLOC));
01468 
01469   /* Via read/recursive, it's possible that the reader will try to
01470      complain about a character that precedes the start of a port.
01471      In that case, pos can be 0. */
01472   if (!pos) line = col = pos = -1;
01473 
01474   if (stxsrc) {
01475     Scheme_Object *xsrc;
01476 
01477     xsrc = scheme_make_stx_w_offset(scheme_false, line, col, pos, span, stxsrc, STX_SRCTAG);
01478 
01479     stxsrc = ((Scheme_Stx *)xsrc)->srcloc->src;
01480     line = ((Scheme_Stx *)xsrc)->srcloc->line;
01481     col = ((Scheme_Stx *)xsrc)->srcloc->col;
01482     pos = ((Scheme_Stx *)xsrc)->srcloc->pos;
01483 
01484     if (show_loc)
01485       fn = make_srcloc_string(((Scheme_Stx *)xsrc)->srcloc, &fnlen);
01486     else
01487       fn = NULL;
01488   } else
01489     fn = NULL;
01490 
01491   if (!fn && show_loc) {
01492     long column;
01493 
01494     if (col < 0)
01495       column = pos;
01496     else
01497       column = col;
01498 
01499     if (port) {
01500       Scheme_Object *pn;
01501       pn = SCHEME_IPORT_NAME(port);
01502       if (SCHEME_PATHP(pn)) {
01503        pn = scheme_remove_current_directory_prefix(pn);
01504        fn = SCHEME_PATH_VAL(pn);
01505       } else
01506        fn = "UNKNOWN";
01507     } else
01508       fn = "UNKNOWN";
01509 
01510     fnlen = strlen(fn);
01511 
01512     if (column >= 0) {
01513       scheme_sprintf(lbuf, 30, ":%L%ld: ", line, column-1);
01514       ls = lbuf;
01515     } else
01516       ls = ": ";
01517   } else if (!show_loc) {
01518     fn = "";
01519     fnlen = 0;
01520   }
01521 
01522   if (indentation)
01523     suggests = scheme_extract_indentation_suggestions(indentation);
01524   else
01525     suggests = "";
01526 
01527   loc = scheme_make_location(stxsrc ? stxsrc : scheme_false,
01528                           (line < 0) ? scheme_false : scheme_make_integer(line),
01529                           (col < 0) ? scheme_false : scheme_make_integer(col-1),
01530                           (pos < 0) ? scheme_false : scheme_make_integer(pos),
01531                           (span < 0) ? scheme_false : scheme_make_integer(span));
01532 
01533   scheme_raise_exn(((gotc == EOF) 
01534                   ? MZEXN_FAIL_READ_EOF 
01535                   : ((gotc == SCHEME_SPECIAL) 
01536                      ? MZEXN_FAIL_READ_NON_CHAR 
01537                      : MZEXN_FAIL_READ)),
01538                  scheme_make_pair(loc, scheme_null),
01539                  "%t%s%t%s",
01540                  fn, fnlen, ls,
01541                  s, slen, suggests);
01542 }
01543 
01544 static void do_wrong_syntax(const char *where,
01545                             Scheme_Object *detail_form,
01546                             Scheme_Object *form,
01547                             char *s, long slen,
01548                             Scheme_Object *extra_sources)
01549 {
01550   long len, vlen, dvlen, blen, plen;
01551   char *buffer;
01552   char *v, *dv, *p;
01553   Scheme_Object *mod, *nomwho, *who;
01554   int show_src;
01555 
01556   who = NULL;
01557   nomwho = NULL;
01558   mod = scheme_false;
01559 
01560   if (!s) {
01561     s = "bad syntax";
01562     slen = strlen(s);
01563   }
01564 
01565   /* Check for special strings that indicate `form' doesn't have a
01566      good name: */
01567   if ((where == scheme_compile_stx_string)
01568       || (where == scheme_expand_stx_string)) {
01569     who = nomwho = scheme_false;
01570   } else if (where == scheme_application_stx_string) {
01571     who = scheme_intern_symbol("#%app");
01572     nomwho = who;
01573     mod = scheme_intern_symbol("mzscheme");
01574   } else if ((where == scheme_set_stx_string)
01575             || (where == scheme_var_ref_string)
01576             || (where == scheme_begin_stx_string)) {
01577     who = scheme_intern_symbol(where);
01578     nomwho = who;
01579     mod = scheme_intern_symbol("mzscheme");
01580     if (where == scheme_begin_stx_string)
01581       where = "begin (possibly implicit)";
01582   }
01583 
01584   buffer = init_buf(&len, &blen);
01585 
01586   p = NULL;
01587   plen = 0;
01588 
01589   show_src = SCHEME_TRUEP(scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PRINT_SRCLOC));
01590 
01591   if (form) {
01592     Scheme_Object *pform;
01593     if (SCHEME_STXP(form)) {
01594       p = make_srcloc_string(((Scheme_Stx *)form)->srcloc, &plen);
01595       pform = scheme_syntax_to_datum(form, 0, NULL);
01596 
01597       /* Try to extract syntax name from syntax */
01598       if (!nomwho && (SCHEME_SYMBOLP(SCHEME_STX_VAL(form)) || SCHEME_STX_PAIRP(form))) {
01599        Scheme_Object *first;
01600        if (SCHEME_STX_PAIRP(form))
01601          first = SCHEME_STX_CAR(form);
01602        else
01603          first = form;
01604        if (SCHEME_SYMBOLP(SCHEME_STX_VAL(first))) {
01605          /* Get module and name at source: */
01606          int phase;
01607          who = SCHEME_STX_VAL(first); /* printed name is local name */
01608          /* name in exception is nominal source: */
01609          if (scheme_current_thread->current_local_env)
01610            phase = scheme_current_thread->current_local_env->genv->phase;
01611          else phase = 0;
01612          scheme_stx_module_name(0, &first, scheme_make_integer(phase), &mod, &nomwho, 
01613                                  NULL, NULL, NULL, NULL, NULL, NULL);
01614        }
01615       }
01616     } else {
01617       pform = form;
01618       if (!detail_form)
01619        form = scheme_datum_to_syntax(form, scheme_false, scheme_false, 1, 0);
01620     }
01621     /* don't use error_write_to_string_w_max since this is code */
01622     if (show_src)
01623       v = scheme_write_to_string_w_max(pform, &vlen, len);
01624     else {
01625       v = NULL;
01626       vlen = 0;
01627     }
01628   } else {
01629     form = scheme_false;
01630     v = NULL;
01631     vlen = 0;
01632   }
01633 
01634   if (detail_form) {
01635     Scheme_Object *pform;
01636     if (SCHEME_STXP(detail_form)) {
01637       if (((Scheme_Stx *)detail_form)->srcloc->line >= 0)
01638        p = make_srcloc_string(((Scheme_Stx *)detail_form)->srcloc, &plen);
01639       pform = scheme_syntax_to_datum(detail_form, 0, NULL);
01640       /* To go in exn record: */
01641       form = detail_form;
01642     } else {
01643       pform = detail_form;
01644       /* To go in exn record: */
01645       form = scheme_datum_to_syntax(detail_form,
01646                                 /* Use source location of `form': */
01647                                 SCHEME_STXP(form) ? form : scheme_false,
01648                                 scheme_false, 1, 0);
01649     }
01650 
01651     /* don't use error_write_to_string_w_max since this is code */
01652     if (show_src)
01653       dv = scheme_write_to_string_w_max(pform, &dvlen, len);
01654     else {
01655       dv = NULL;
01656       dvlen = 0;
01657     }
01658   } else {
01659     dv = NULL;
01660     dvlen = 0;
01661   }
01662 
01663   if (!who) {
01664     if (where)
01665       who = scheme_intern_symbol(where);
01666     else
01667       who = scheme_false;
01668   }
01669   if (!nomwho)
01670     nomwho = who;
01671 
01672   if (!where) {
01673     if (SCHEME_FALSEP(who))
01674       where = "?";
01675     else
01676       where = scheme_symbol_val(who);
01677   }
01678 
01679   if (v) {
01680     if (dv)
01681       blen = scheme_sprintf(buffer, blen, "%t%s: %t at: %t in: %t",
01682                          p, plen,
01683                          where, s, slen,
01684                          dv, dvlen,
01685                          v, vlen);
01686     else
01687       blen = scheme_sprintf(buffer, blen, "%t%s: %t in: %t",
01688                          p, plen,
01689                          where, s, slen,
01690                          v, vlen);
01691   } else
01692     blen = scheme_sprintf(buffer, blen, "%s: %t", where, s, slen);
01693 
01694   /* We don't actually use nomwho and mod, anymore. */
01695 
01696   if (SCHEME_FALSEP(form))
01697     form = extra_sources;
01698   else
01699     form = scheme_make_pair(form, extra_sources);
01700 
01701   scheme_raise_exn(MZEXN_FAIL_SYNTAX, 
01702                  form,
01703                  "%t", buffer, blen);
01704 }
01705 
01706 void scheme_wrong_syntax(const char *where,
01707                       Scheme_Object *detail_form,
01708                       Scheme_Object *form,
01709                       const char *detail, ...)
01710 {
01711   char *s;
01712   long slen;
01713 
01714   if (!detail) {
01715     s = NULL;
01716     slen = 0;
01717   } else {
01718     GC_CAN_IGNORE va_list args;
01719 
01720     HIDE_FROM_XFORM(va_start(args, detail));
01721     slen = sch_vsprintf(NULL, 0, detail, args, &s);
01722     HIDE_FROM_XFORM(va_end(args));
01723   }
01724 
01725   do_wrong_syntax(where, detail_form, form, s, slen, scheme_null);
01726 }
01727 
01728 void scheme_wrong_syntax_with_more_sources(const char *where,
01729                                            Scheme_Object *detail_form,
01730                                            Scheme_Object *form,
01731                                            Scheme_Object *extra_sources,
01732                                            const char *detail, ...)
01733 {
01734   char *s;
01735   long slen;
01736 
01737   if (!detail) {
01738     s = NULL;
01739     slen = 0;
01740   } else {
01741     GC_CAN_IGNORE va_list args;
01742 
01743     HIDE_FROM_XFORM(va_start(args, detail));
01744     slen = sch_vsprintf(NULL, 0, detail, args, &s);
01745     HIDE_FROM_XFORM(va_end(args));
01746   }
01747 
01748   do_wrong_syntax(where, detail_form, form, s, slen, extra_sources);
01749 }
01750 
01751 void scheme_wrong_rator(Scheme_Object *rator, int argc, Scheme_Object **argv)
01752 {
01753   long len, slen;
01754   int rlen;
01755   char *s, *r;
01756 
01757   s = init_buf(&len, NULL);
01758 
01759   r = scheme_make_provided_string(rator, 1, &rlen);
01760 
01761   if (argc)
01762     len /= argc;
01763 
01764   slen = 0;
01765   if (argc && (argc < 50) && (len >= 3)) {
01766     int i;
01767 
01768     strcpy(s, "; arguments were:");
01769     slen = 17;
01770     for (i = 0; i < argc; i++) {
01771       char *o;
01772       int olen;
01773 
01774       o = error_write_to_string_w_max(argv[i], len, &olen);
01775       memcpy(s + slen, " ", 1);
01776       memcpy(s + slen + 1, o, olen);
01777       slen += 1 + olen;
01778     }
01779     s[slen] = 0;
01780   } else {
01781     slen = -1;
01782     if (argc)
01783       sprintf(s, " (%d args)", argc);
01784     else
01785       s = " (no arguments)";
01786   }
01787 
01788   scheme_raise_exn(MZEXN_FAIL_CONTRACT,
01789                  "procedure application: expected procedure, given: %t%t",
01790                  r, rlen, s, slen);
01791 }
01792 
01793 void scheme_wrong_return_arity(const char *where,
01794                             int expected, int got,
01795                             Scheme_Object **argv,
01796                             const char *detail, ...)
01797 {
01798   long slen, vlen, blen;
01799   char *s, *buffer;
01800   char *v;
01801 
01802   if ((got != 1) && SAME_OBJ(scheme_current_thread->ku.multiple.array,
01803                           scheme_current_thread->values_buffer))
01804     scheme_current_thread->values_buffer = NULL;
01805   scheme_current_thread->ku.multiple.array = NULL;
01806 
01807   if (!detail) {
01808     s = NULL;
01809     slen = 0;
01810   } else {
01811     GC_CAN_IGNORE va_list args;
01812 
01813     HIDE_FROM_XFORM(va_start(args, detail));
01814     slen = sch_vsprintf(NULL, 0, detail, args, &s);
01815     HIDE_FROM_XFORM(va_end(args));
01816   }
01817 
01818   buffer = init_buf(NULL, &blen);
01819 
01820   if (!got || !argv) {
01821     v = "";
01822     vlen = 0;
01823   } else {
01824     int i;
01825     long len, origlen, maxpos;
01826     Scheme_Object **array;
01827 
01828     v = init_buf(&len, NULL);
01829     v[0] = ':';
01830     v[1] = 0;
01831 
01832     array = ((got == 1) ? (Scheme_Object **) mzALIAS &argv : argv);
01833 
01834     origlen = len;
01835     len /= got;
01836 
01837     maxpos = got;
01838     if (len < 3) {
01839       maxpos = origlen / 4;
01840       len = 3;
01841     }
01842 
01843     vlen = 1;
01844     for (i = 0; i < maxpos; i++) {
01845       char *o;
01846       int olen;
01847 
01848       o = error_write_to_string_w_max(array[i], len, &olen);
01849       memcpy(v + vlen, " ", 1);
01850       memcpy(v + vlen + 1, o, olen);
01851       vlen += 1 + olen;
01852     }
01853 
01854     if (maxpos != got) {
01855       strcpy(v + vlen, " ...");
01856       vlen += 4;
01857     }
01858     v[vlen] = 0;
01859   }
01860 
01861   blen = scheme_sprintf(buffer,
01862                      blen,
01863                      "%s%scontext%s%t%s expected %d value%s,"
01864                      " received %d value%s%t",
01865                      where ? where : "",
01866                      where ? ": " : "",
01867                      s ? " (" : "",
01868                      s ? s : "",
01869                      slen,
01870                      s ? ")" : "",
01871                      expected,
01872                      (expected == 1) ? "" : "s",
01873                      got,
01874                      (got == 1) ? "" : "s",
01875                      v, vlen);
01876 
01877   scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY,
01878                  "%t",
01879                  buffer, blen);
01880 }
01881 
01882 void scheme_raise_out_of_memory(const char *where, const char *msg, ...)
01883 {
01884   char *s;
01885   long slen;
01886 
01887   if (!msg) {
01888     s = "";
01889     slen = 0;
01890   } else {
01891     GC_CAN_IGNORE va_list args;
01892 
01893     HIDE_FROM_XFORM(va_start(args, msg));
01894     slen = sch_vsprintf(NULL, 0, msg, args, &s);
01895     HIDE_FROM_XFORM(va_end(args));
01896   }
01897 
01898   scheme_raise_exn(MZEXN_FAIL_OUT_OF_MEMORY,
01899                  "%s%sout of memory %t",
01900                  where ? where : "",
01901                  where ? ": " : "",
01902                  s, slen);
01903 }
01904 
01905 void scheme_unbound_global(Scheme_Bucket *b)
01906 {
01907   Scheme_Object *name = (Scheme_Object *)b->key;
01908 
01909   if (((Scheme_Bucket_With_Home *)b)->home->module) {
01910     const char *errmsg;
01911     char *phase, phase_buf[20];
01912     
01913     if (SCHEME_TRUEP(scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PRINT_SRCLOC)))
01914       errmsg = "reference to an identifier before its definition: %S in module: %D%s";
01915     else
01916       errmsg = "reference to an identifier before its definition: %S%_%s";
01917 
01918     if (SCHEME_INT_VAL(((Scheme_Bucket_With_Home *)b)->home->phase)) {
01919       sprintf(phase_buf, " phase: %ld", SCHEME_INT_VAL(((Scheme_Bucket_With_Home *)b)->home->phase));
01920       phase = phase_buf;
01921     } else
01922       phase = "";
01923 
01924     scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE,
01925                    name,
01926                    errmsg,
01927                    name,
01928                    ((Scheme_Bucket_With_Home *)b)->home->module->modname,
01929                      phase);
01930   } else {
01931     scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE,
01932                    name,
01933                    "reference to undefined identifier: %S",
01934                    name);
01935   }
01936 }
01937 
01938 char *scheme_make_provided_string(Scheme_Object *o, int count, int *lenout)
01939 {
01940   long len;
01941 
01942   len = get_print_width();
01943 
01944   if (count)
01945     len /= count;
01946 
01947   return error_write_to_string_w_max(o, len, lenout);
01948 }
01949 
01950 static Scheme_Object *do_error(int for_user, int argc, Scheme_Object *argv[])
01951 {
01952   Scheme_Object *newargs[2];
01953 
01954   if (SCHEME_SYMBOLP(argv[0])) {
01955     if (argc < 2) {
01956       const char *s;
01957       int l;
01958 
01959       s = scheme_symbol_val(argv[0]);
01960       l = SCHEME_SYM_LEN(argv[0]);
01961 
01962       /* Just a symbol */
01963       newargs[0] =
01964        scheme_append_char_string(scheme_make_utf8_string("error: "),
01965                               scheme_make_sized_utf8_string((char *)s, l));
01966       
01967       SCHEME_SET_CHAR_STRING_IMMUTABLE(newargs[0]);
01968     } else {
01969       char *s, *r;
01970       long l, l2;
01971       Scheme_Object *port;
01972       port = scheme_make_byte_string_output_port();
01973 
01974       /* Chez-style: symbol, format string, format items... */
01975       if (!SCHEME_CHAR_STRINGP(argv[1]))
01976        scheme_wrong_type("error", "string", 1, argc, argv);
01977 
01978       scheme_do_format("error", port, NULL, -1, 1, 2, argc, argv);
01979 
01980       s = scheme_get_sized_byte_string_output(port, &l);
01981 
01982       l2 = SCHEME_SYM_LEN(argv[0]);
01983       r = MALLOC_N_ATOMIC(char, l + l2 + 3);
01984       memcpy(r, SCHEME_SYM_VAL(argv[0]), l2);
01985       memcpy(r + l2, ": ", 2);
01986       memcpy(r + l2 + 2, s, l + 1);
01987 
01988       newargs[0] = scheme_make_immutable_sized_utf8_string(r, l + l2 + 2);
01989     }
01990   } else {
01991     Scheme_Object *strout;
01992     char *str;
01993     long len, i;
01994 
01995     /* String followed by other values: */
01996     if (!SCHEME_CHAR_STRINGP(argv[0]))
01997       scheme_wrong_type("error", "string or symbol", 0, argc, argv);
01998 
01999     strout = scheme_make_byte_string_output_port();
02000 
02001     scheme_internal_display(argv[0], strout);
02002     for (i = 1; i < argc ; i++) {
02003       scheme_write_byte_string(" ", 1, strout);
02004       scheme_internal_write(argv[i], strout);
02005     }
02006 
02007     str = scheme_get_sized_byte_string_output(strout, &len);
02008     newargs[0] = scheme_make_immutable_sized_utf8_string(str, len);
02009   }
02010 
02011 #ifndef NO_SCHEME_EXNS
02012   newargs[1] = TMP_CMARK_VALUE;
02013   do_raise(scheme_make_struct_instance(exn_table[for_user ? MZEXN_FAIL_USER : MZEXN_FAIL].type,
02014                                    2, newargs),
02015           1,
02016            1);
02017 
02018   return scheme_void;
02019 #else
02020   _scheme_apply_multi(scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_DISPLAY_HANDLER), 1, newargs);
02021 
02022   return _scheme_tail_apply(scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_ESCAPE_HANDLER),
02023                          0, NULL);
02024 #endif
02025 }
02026 
02027 static Scheme_Object *error(int argc, Scheme_Object *argv[])
02028 {
02029   return do_error(0, argc, argv);
02030 }
02031 
02032 static Scheme_Object *raise_user_error(int argc, Scheme_Object *argv[])
02033 {
02034     return do_error(1, argc, argv);
02035 }
02036 
02037 static Scheme_Object *raise_syntax_error(int argc, Scheme_Object *argv[])
02038 {
02039   const char *who;
02040   Scheme_Object *str, *extra_sources = scheme_null;
02041 
02042   if (!SCHEME_FALSEP(argv[0]) && !SCHEME_SYMBOLP(argv[0]))
02043     scheme_wrong_type("raise-syntax-error", "symbol or #f", 0, argc, argv);
02044   if (!SCHEME_CHAR_STRINGP(argv[1]))
02045     scheme_wrong_type("raise-syntax-error", "string", 1, argc, argv);
02046 
02047   if (SCHEME_SYMBOLP(argv[0]))
02048     who = scheme_symbol_val(argv[0]);
02049   else
02050     who = NULL;
02051 
02052   str = argv[1];
02053   if (SCHEME_MUTABLEP(str)) {
02054     str = scheme_make_immutable_sized_char_string(SCHEME_CHAR_STR_VAL(str), 
02055                                             SCHEME_CHAR_STRLEN_VAL(str), 
02056                                             1);
02057   }
02058 
02059   if (argc > 4) {
02060     extra_sources = argv[4];
02061     while (SCHEME_PAIRP(extra_sources)) {
02062       if (!SCHEME_STXP(SCHEME_CAR(extra_sources)))
02063         break;
02064       extra_sources = SCHEME_CDR(extra_sources);
02065     }
02066     if (!SCHEME_NULLP(extra_sources)) {
02067       scheme_wrong_type("raise-syntax-error", "list of syntax", 4, argc, argv);
02068       return NULL;
02069     }
02070     extra_sources = argv[4];
02071   }
02072 
02073   scheme_wrong_syntax_with_more_sources(who,
02074                                         ((argc > 3) && !SCHEME_FALSEP(argv[3])) ? argv[3] : NULL,
02075                                         ((argc > 2) && !SCHEME_FALSEP(argv[2])) ? argv[2] : NULL,
02076                                         extra_sources,
02077                                         "%T", str);
02078 
02079   return NULL;
02080 }
02081 
02082 static Scheme_Object *raise_type_error(int argc, Scheme_Object *argv[])
02083 {
02084   if (!SCHEME_SYMBOLP(argv[0]))
02085     scheme_wrong_type("raise-type-error", "symbol", 0, argc, argv);
02086   if (!SCHEME_CHAR_STRINGP(argv[1]))
02087     scheme_wrong_type("raise-type-error", "string", 1, argc, argv);
02088 
02089   if (argc == 3) {
02090     Scheme_Object *v, *s;
02091     v = argv[2];
02092     s = scheme_char_string_to_byte_string(argv[1]);
02093     scheme_wrong_type(scheme_symbol_val(argv[0]),
02094                     SCHEME_BYTE_STR_VAL(s),
02095                     -1, 0, &v);
02096   } else {
02097     Scheme_Object **args, *s;
02098     int i;
02099 
02100     if (!(SCHEME_INTP(argv[2]) && (SCHEME_INT_VAL(argv[2]) >= 0))
02101        && !(SCHEME_BIGNUMP(argv[2]) && SCHEME_BIGPOS(argv[2])))
02102       scheme_wrong_type("raise-type-error", "exact non-negative integer", 2, argc, argv);
02103 
02104     if ((SCHEME_INTP(argv[2]) && (SCHEME_INT_VAL(argv[2]) >= argc - 3))
02105        || SCHEME_BIGNUMP(argv[2]))
02106       scheme_raise_exn(MZEXN_FAIL_CONTRACT,
02107                      "raise-type-error: position index is %V, "
02108                      "but only %d arguments provided",
02109                      argv[2],
02110                      argc - 3);
02111 
02112     args = MALLOC_N(Scheme_Object *, argc - 3);
02113     for (i = 3; i < argc; i++) {
02114       args[i - 3] = argv[i];
02115     }
02116 
02117     s = scheme_char_string_to_byte_string(argv[1]);
02118 
02119     scheme_wrong_type(scheme_symbol_val(argv[0]),
02120                     SCHEME_BYTE_STR_VAL(s),
02121                     SCHEME_INT_VAL(argv[2]),
02122                     argc - 3, args);
02123   }
02124 
02125   return NULL;
02126 }
02127 
02128 static Scheme_Object *raise_mismatch_error(int argc, Scheme_Object *argv[])
02129 {
02130   Scheme_Object *s;
02131 
02132   if (!SCHEME_SYMBOLP(argv[0]))
02133     scheme_wrong_type("raise-mismatch-error", "symbol", 0, argc, argv);
02134   if (!SCHEME_CHAR_STRINGP(argv[1]))
02135     scheme_wrong_type("raise-mismatch-error", "string", 1, argc, argv);
02136 
02137   s = scheme_char_string_to_byte_string(argv[1]);
02138 
02139   scheme_arg_mismatch(scheme_symbol_val(argv[0]),
02140                     SCHEME_BYTE_STR_VAL(s),
02141                     argv[2]);
02142 
02143   return NULL;
02144 }
02145 
02146 static int is_arity_at_least(Scheme_Object *v)
02147 {
02148   return (SCHEME_STRUCTP(v)
02149           && scheme_is_struct_instance(scheme_arity_at_least, v)
02150           && scheme_nonneg_exact_p(((Scheme_Structure *)v)->slots[0]));
02151 }
02152 
02153 static int is_arity_list(Scheme_Object *l)
02154 {
02155   int c;
02156   Scheme_Object *a;
02157 
02158   c = scheme_proper_list_length(l);
02159   if (c < 0) return 0;
02160   while (!SCHEME_NULLP(l)) {
02161     a = SCHEME_CAR(l);
02162     if (!scheme_nonneg_exact_p(a)
02163         && !scheme_nonneg_exact_p(a))
02164       return 0;
02165     l = SCHEME_CDR(l);
02166   }
02167 
02168   return 1;
02169 }
02170 
02171 static Scheme_Object *raise_arity_error(int argc, Scheme_Object *argv[])
02172 {
02173   Scheme_Object **args;
02174   const char *name;
02175   int minc, maxc;
02176 
02177   if (!SCHEME_SYMBOLP(argv[0]) && !SCHEME_PROCP(argv[0]))
02178     scheme_wrong_type("raise-arity-error", "symbol or procedure", 0, argc, argv);
02179   if (!scheme_nonneg_exact_p(argv[1]) 
02180       && !is_arity_at_least(argv[1])
02181       && !is_arity_list(argv[1]))
02182     scheme_wrong_type("raise-mismatch-error", "arity (integer, arity-at-least, or list)", 1, argc, argv);
02183 
02184   args = MALLOC_N(Scheme_Object*, argc - 2);
02185   memcpy(args, argv + 2, sizeof(Scheme_Object*) * (argc - 2));
02186 
02187   if (SCHEME_SYMBOLP(argv[0]))
02188     name = scheme_symbol_val(argv[0]);
02189   else {
02190     int len;
02191     name = scheme_get_proc_name(argv[0], &len, 1);
02192   }
02193 
02194   if (SCHEME_INTP(argv[1])) {
02195     minc = maxc = SCHEME_INT_VAL(argv[1]);
02196   } else if (is_arity_at_least(argv[1])) {
02197     Scheme_Object *v;
02198     v = ((Scheme_Structure *)argv[1])->slots[0];
02199     if (SCHEME_INTP(v)) {
02200       minc = SCHEME_INT_VAL(v);
02201       maxc = -1;
02202     } else {
02203       minc = -2;
02204       maxc = 0;
02205     }
02206   } else {
02207     minc = -2;
02208     maxc = 0;
02209   }
02210 
02211   scheme_wrong_count_m(name, minc, maxc, argc - 2, args, 0);
02212 
02213   return NULL;
02214 }
02215 
02216 static Scheme_Object *good_print_width(int c, Scheme_Object **argv)
02217 {
02218   int ok;
02219 
02220   ok = (SCHEME_INTP(argv[0]) 
02221        ? (SCHEME_INT_VAL(argv[0]) > 3)
02222        : (SCHEME_BIGNUMP(argv[0])
02223           ? SCHEME_BIGPOS(argv[0])
02224           : 0));
02225 
02226   return ok ? scheme_true : scheme_false;
02227 }
02228 
02229 static Scheme_Object *error_print_width(int argc, Scheme_Object *argv[])
02230 {
02231   return scheme_param_config("error-print-width",
02232                           scheme_make_integer(MZCONFIG_ERROR_PRINT_WIDTH),
02233                           argc, argv,
02234                           -1, good_print_width, "integer greater than three", 0);
02235 }
02236 
02237 static Scheme_Object *good_print_context_length(int c, Scheme_Object **argv)
02238 {
02239   int ok;
02240 
02241   ok = (SCHEME_INTP(argv[0]) 
02242        ? (SCHEME_INT_VAL(argv[0]) >= 0)
02243        : (SCHEME_BIGNUMP(argv[0])
02244           ? SCHEME_BIGPOS(argv[0])
02245           : 0));
02246 
02247   return ok ? scheme_true : scheme_false;
02248 }
02249 
02250 static Scheme_Object *error_print_context_length(int argc, Scheme_Object *argv[])
02251 {
02252   return scheme_param_config("error-print-context-length",
02253                           scheme_make_integer(MZCONFIG_ERROR_PRINT_CONTEXT_LENGTH),
02254                           argc, argv,
02255                           -1, good_print_context_length, "non-negative integer", 0);
02256 }
02257 
02258 static Scheme_Object *error_print_srcloc(int argc, Scheme_Object *argv[])
02259 {
02260   return scheme_param_config("error-print-source-location",
02261                           scheme_make_integer(MZCONFIG_ERROR_PRINT_SRCLOC),
02262                           argc, argv,
02263                           -1, NULL, NULL, 1);
02264 }
02265 
02266 void scheme_write_proc_context(Scheme_Object *port, int print_width,
02267                                Scheme_Object *name, 
02268                                Scheme_Object *src, Scheme_Object *line, 
02269                                Scheme_Object *col, Scheme_Object *pos,
02270                                int generated)
02271 {
02272   if (src) {
02273     scheme_display_w_max(src, port, print_width);
02274     if (line && SCHEME_TRUEP(line)) {
02275       /* Line + column */
02276       scheme_write_byte_string(":", 1, port);
02277       scheme_display_w_max(line, port, print_width);
02278       scheme_write_byte_string(":", 1, port);
02279       scheme_display_w_max(col, port, print_width);
02280     } else {
02281       /* Position */
02282       scheme_write_byte_string("::", 2, port);
02283       scheme_display_w_max(pos, port, print_width);
02284     }
02285     
02286     if (SCHEME_TRUEP(name)) {
02287       scheme_write_byte_string(": ", 2, port);
02288     }
02289   }
02290   
02291   if (SCHEME_TRUEP(name)) {
02292     scheme_display_w_max(name, port, print_width);
02293   }
02294 }
02295 
02296 static Scheme_Object *
02297 def_error_display_proc(int argc, Scheme_Object *argv[])
02298 {
02299   Scheme_Config *config;
02300   Scheme_Object *port, *s;
02301 
02302   config = scheme_current_config();
02303   port = scheme_get_param(config, MZCONFIG_ERROR_PORT);
02304 
02305   if (!SCHEME_CHAR_STRINGP(argv[0]))
02306     scheme_wrong_type("default-error-display-handler", "string", 0, argc, argv);
02307   /* don't care about argv[1] */
02308 
02309   s = scheme_char_string_to_byte_string(argv[0]);
02310 
02311   scheme_write_byte_string(SCHEME_BYTE_STR_VAL(s),
02312                         SCHEME_BYTE_STRTAG_VAL(s),
02313                         port);
02314   scheme_write_byte_string("\n", 1, port);
02315 
02316   /* Print context, if available */
02317   if (SCHEME_STRUCTP(argv[1])
02318       && scheme_is_struct_instance(exn_table[MZEXN].type, argv[1])
02319       && !scheme_is_struct_instance(exn_table[MZEXN_FAIL_USER].type, argv[1])) {
02320     Scheme_Object *l, *w;
02321     int print_width = 1024, max_cnt = 16;
02322 
02323     w = scheme_get_param(config, MZCONFIG_ERROR_PRINT_CONTEXT_LENGTH);
02324     if (SCHEME_INTP(w))
02325       max_cnt = SCHEME_INT_VAL(w);
02326     else
02327       max_cnt = 0x7FFFFFFF;
02328 
02329     if (max_cnt) {
02330       int orig_max_cnt = max_cnt;
02331       w = scheme_get_param(config, MZCONFIG_ERROR_PRINT_WIDTH);
02332       if (SCHEME_INTP(w))
02333        print_width = SCHEME_INT_VAL(w);
02334       else
02335        print_width = 0x7FFFFFFF;
02336       l = scheme_get_stack_trace(((Scheme_Structure *)argv[1])->slots[1]);
02337       while (!SCHEME_NULLP(l)) {
02338        if (!max_cnt) {
02339          scheme_write_byte_string("...\n", 4, port);
02340          break;
02341        } else {
02342          Scheme_Object *name, *loc;
02343          
02344          if (max_cnt == orig_max_cnt) {
02345            /* Starting label: */
02346            scheme_write_byte_string("\n === context ===\n", 18, port);
02347          }
02348 
02349          name = SCHEME_CAR(l);
02350          loc = SCHEME_CDR(name);
02351          name = SCHEME_CAR(name);
02352 
02353           if (SCHEME_TRUEP(loc)) {
02354             Scheme_Structure *sloc = (Scheme_Structure *)loc;
02355             scheme_write_proc_context(port, print_width, 
02356                                       name, 
02357                                       sloc->slots[0], sloc->slots[1],
02358                                       sloc->slots[2], sloc->slots[3],
02359                                       0);
02360           } else {
02361             scheme_write_proc_context(port, print_width, 
02362                                       name, 
02363                                       NULL, NULL, NULL, NULL, 
02364                                       0);
02365           }
02366 
02367          scheme_write_byte_string("\n", 1, port);
02368          l = SCHEME_CDR(l);
02369          --max_cnt;
02370        }
02371       }
02372 
02373       if (max_cnt != orig_max_cnt) {
02374        /* Extra ending newline */
02375        scheme_write_byte_string("\n", 1, port);
02376       }
02377     }
02378   }
02379 
02380   return scheme_void;
02381 }
02382 
02383 static Scheme_Object *
02384 emergency_error_display_proc(int argc, Scheme_Object *argv[])
02385 {
02386   Scheme_Object *s;
02387 
02388   if (!SCHEME_CHAR_STRINGP(argv[0]))
02389     return scheme_void;
02390 
02391   s = scheme_char_string_to_byte_string(argv[0]);
02392 
02393   scheme_console_output(SCHEME_BYTE_STR_VAL(s),
02394                      SCHEME_BYTE_STRTAG_VAL(s));
02395   scheme_console_output("\n", 1);
02396 
02397   return scheme_void;
02398 }
02399 
02400 static Scheme_Object *
02401 def_error_value_string_proc(int argc, Scheme_Object *argv[])
02402 {
02403   long origl, len, l;
02404   char *s;
02405   Scheme_Object *pph;
02406 
02407   if (!SCHEME_INTP(argv[1]))
02408     scheme_wrong_type("default-error-value->string-handler", "number", 1, argc, argv);
02409 
02410   origl = len = SCHEME_INT_VAL(argv[1]);
02411 
02412   pph = scheme_get_param(scheme_current_config(), MZCONFIG_PORT_PRINT_HANDLER);
02413   if (SAME_OBJ(pph, scheme_default_global_print_handler)) {
02414     if (len < 3)
02415       len = 3;
02416 
02417     s = scheme_print_to_string_w_max(argv[0], &l, len);
02418 
02419     if ((origl < 3) && (l > origl))
02420       l = origl;
02421   } else {
02422     Scheme_Object *a[2];
02423 
02424     a[0] = argv[0];
02425     a[1] = scheme_make_byte_string_output_port();
02426     _scheme_apply(pph, 2, a);
02427 
02428     s = scheme_get_sized_byte_string_output(a[1], &l);
02429 
02430     if (l > origl) {
02431       /* FIXME: might hit the middle of a UTF-8 encoding. */
02432       l = origl;
02433       if (origl >= 1) {
02434        s[origl - 1] = '.';
02435        if (origl >= 2) {
02436          s[origl - 2] = '.';
02437          if (origl >= 3)
02438            s[origl - 3] = '.';
02439        }
02440       }
02441     }
02442   }
02443 
02444   return scheme_make_sized_utf8_string(s, l);
02445 }
02446 
02447 static Scheme_Object *
02448 def_error_escape_proc(int argc, Scheme_Object *argv[])
02449 {  
02450   Scheme_Object *prompt;
02451   Scheme_Thread *p = scheme_current_thread;
02452 
02453   prompt = scheme_extract_one_cc_mark(NULL, SCHEME_PTR_VAL(scheme_default_prompt_tag));
02454 
02455   if (prompt) {
02456     p->cjs.jumping_to_continuation = prompt;
02457     p->cjs.num_vals = 1;
02458     p->cjs.val = scheme_void_proc;
02459   }
02460   scheme_longjmp(scheme_error_buf, 1);
02461 
02462   return scheme_void; /* Never get here */
02463 }
02464 
02465 static Scheme_Object *
02466 error_display_handler(int argc, Scheme_Object *argv[])
02467 {
02468   return scheme_param_config("error-display-handler",
02469                           scheme_make_integer(MZCONFIG_ERROR_DISPLAY_HANDLER),
02470                           argc, argv,
02471                           2, NULL, NULL, 0);
02472 }
02473 
02474 static Scheme_Object *
02475 error_value_string_handler(int argc, Scheme_Object *argv[])
02476 {
02477   return scheme_param_config("error-value->string-handler",
02478                           scheme_make_integer(MZCONFIG_ERROR_PRINT_VALUE_HANDLER),
02479                           argc, argv,
02480                           2, NULL, NULL, 0);
02481 }
02482 
02483 static Scheme_Object *
02484 error_escape_handler(int argc, Scheme_Object *argv[])
02485 {
02486   return scheme_param_config("error-escape-handler",
02487                           scheme_make_integer(MZCONFIG_ERROR_ESCAPE_HANDLER),
02488                           argc, argv,
02489                           0, NULL, NULL, 0);
02490 }
02491 
02492 static Scheme_Object *
02493 exit_handler(int argc, Scheme_Object *argv[])
02494 {
02495   return scheme_param_config("exit-handler",
02496                           scheme_make_integer(MZCONFIG_EXIT_HANDLER),
02497                           argc, argv,
02498                           1, NULL, NULL, 0);
02499 }
02500 
02501 int scheme_exiting_result; /* used by hack in port.c */
02502 
02503 static Scheme_Object *
02504 def_exit_handler_proc(int argc, Scheme_Object *argv[])
02505 {
02506   long status;
02507 
02508   if (SCHEME_INTP(argv[0])) {
02509     status = SCHEME_INT_VAL(argv[0]);
02510     if (status < 1 || status > 255)
02511       status = 0;
02512   } else
02513     status = 0;
02514 
02515   scheme_exiting_result = status;
02516 
02517   if (scheme_exit)
02518     scheme_exit(status);
02519   else
02520     exit(status);
02521 
02522   return scheme_void;
02523 }
02524 
02525 Scheme_Object *
02526 scheme_do_exit(int argc, Scheme_Object *argv[])
02527 {
02528   long status;
02529   Scheme_Object *handler;
02530 
02531   if (argc == 1) {
02532     if (SCHEME_INTP(argv[0]))
02533       status = SCHEME_INT_VAL(argv[0]);
02534     else
02535       status = 0;
02536   } else
02537     status = 0;
02538 
02539   handler = scheme_get_param(scheme_current_config(), MZCONFIG_EXIT_HANDLER);
02540 
02541   if (handler) {
02542     Scheme_Object *p[1];
02543 
02544     p[0] = argc ? argv[0] : scheme_make_integer(status);
02545     scheme_apply_multi(handler, 1, p);
02546   } else if (scheme_exit)
02547     scheme_exit(status);
02548   else
02549     exit(status);
02550 
02551   return scheme_void;
02552 }
02553 
02554 /* scheme_immediate_exit ensures that a call to exit() goes to the C
02555    library used by the MzScheme DLL, and not some other copy of the
02556    library (in Windows) */
02557 void scheme_immediate_exit(int status)
02558 {
02559   exit(status);
02560 }
02561 
02562 /***********************************************************************/
02563 
02564 void update_want_level(Scheme_Logger *logger)
02565 {
02566   Scheme_Log_Reader *lr;
02567   Scheme_Object *stack = NULL, *queue, *b, *prev;
02568   Scheme_Logger *parent = logger;
02569   int want_level;
02570 
02571   while (parent) {
02572     stack = scheme_make_raw_pair((Scheme_Object *)parent, stack);
02573 
02574     if (parent->local_timestamp < *parent->timestamp)
02575       parent = parent->parent;
02576     else
02577       parent = NULL;
02578   }
02579 
02580   want_level = 0;
02581   while (stack) {
02582     parent = (Scheme_Logger *)SCHEME_CAR(stack);
02583     
02584     if (parent->local_timestamp < *parent->timestamp) {
02585       queue = parent->readers;
02586       prev = NULL;
02587       while (queue) {
02588         b = SCHEME_CAR(queue);
02589         b = SCHEME_CAR(b);
02590         lr = (Scheme_Log_Reader *)SCHEME_BOX_VAL(b);
02591         if (lr) {
02592           if (lr->want_level > want_level)
02593             want_level = lr->want_level;
02594           prev = queue;
02595         } else {
02596           if (prev)
02597             SCHEME_CDR(prev) = SCHEME_CDR(queue);
02598           else
02599             parent->readers = SCHEME_CDR(queue);
02600         }
02601         queue = SCHEME_CDR(queue);
02602       }
02603 
02604       if (parent->syslog_level > want_level)
02605         want_level = parent->syslog_level;
02606       if (parent->stderr_level > want_level)
02607         want_level = parent->stderr_level;    
02608       
02609       parent->want_level = want_level;
02610       parent->local_timestamp = *parent->timestamp;
02611     } else {
02612       want_level = parent->want_level;
02613     }
02614 
02615     stack = SCHEME_CDR(stack);
02616   }
02617 }
02618 
02619 #ifdef USE_WINDOWS_EVENT_LOG
02620 static int event_procs_ready;
02621 typedef HANDLE (WINAPI *mzRegisterEventSourceProc)(LPCTSTR lpUNCServerName, LPCTSTR lpSourceName);
02622 typedef BOOL (WINAPI *mzReportEventProc)(HANDLE hEventLog, WORD wType, WORD wCategory, DWORD dwEventID,
02623                                                            PSID lpUserSid, WORD wNumStrings, DWORD dwDataSize, LPCTSTR* lpStrings,
02624                                                               LPVOID lpRawData);
02625 static mzRegisterEventSourceProc mzRegisterEventSource;
02626 static mzReportEventProc mzReportEvent;
02627 #endif
02628 
02629 void scheme_log_message(Scheme_Logger *logger, int level, char *buffer, long len, Scheme_Object *data)
02630 {
02631   /* This function must avoid GC allocation when called with the
02632      configuration of scheme_log_abort(). */
02633   Scheme_Logger *orig_logger;
02634   Scheme_Object *queue, *q, *msg = NULL, *b;
02635   Scheme_Log_Reader *lr;
02636 
02637   if (!logger) {
02638     Scheme_Config *config;
02639     config = scheme_current_config();
02640     logger = (Scheme_Logger *)scheme_get_param(config, MZCONFIG_LOGGER);
02641   }
02642 
02643   if (logger->local_timestamp < *logger->timestamp)
02644     update_want_level(logger);
02645 
02646   orig_logger = logger;
02647 
02648   while (logger) {
02649     if (logger->want_level < level)
02650       return;
02651   
02652     if (logger->syslog_level >= level) {
02653 #ifdef USE_C_SYSLOG
02654       int pri;
02655       switch (level) {
02656       case SCHEME_LOG_FATAL:
02657         pri = LOG_CRIT;
02658         break;
02659       case SCHEME_LOG_ERROR:
02660         pri = LOG_ERR;
02661         break;
02662       case SCHEME_LOG_WARNING:
02663         pri = LOG_WARNING;
02664         break;
02665       case SCHEME_LOG_INFO:
02666         pri = LOG_INFO;
02667         break;
02668       case SCHEME_LOG_DEBUG:
02669       default:
02670         pri = LOG_DEBUG;
02671         break;
02672       }
02673       if (orig_logger->name)
02674         syslog(pri, "%s: %s", SCHEME_SYM_VAL(orig_logger->name), buffer);
02675       else
02676         syslog(pri, "%s", buffer);
02677 #endif
02678 #ifdef USE_WINDOWS_EVENT_LOG
02679       if (!event_procs_ready) {
02680         HMODULE hm;
02681         hm = LoadLibrary("advapi32.dll");
02682         if (hm) {
02683           mzRegisterEventSource = (mzRegisterEventSourceProc)GetProcAddress(hm, "RegisterEventSourceA");
02684           mzReportEvent = (mzReportEventProc)GetProcAddress(hm, "ReportEventA");
02685         }
02686         event_procs_ready = 1;
02687       }
02688       if (mzRegisterEventSource) {
02689         static HANDLE hEventLog;
02690         WORD ty;
02691         unsigned long sev;
02692         LPCTSTR a[1];
02693 
02694         if (!hEventLog) {
02695           Scheme_Object *cmd;
02696           cmd = scheme_get_run_cmd();
02697           hEventLog = mzRegisterEventSource(NULL, SCHEME_PATH_VAL(cmd));
02698         }
02699 
02700         switch (level) {
02701         case SCHEME_LOG_FATAL:
02702           ty = EVENTLOG_ERROR_TYPE;
02703           sev = 3;
02704           break;
02705         case SCHEME_LOG_ERROR:
02706           ty = EVENTLOG_ERROR_TYPE;
02707           sev = 3;
02708           break;
02709         case SCHEME_LOG_WARNING:
02710           ty = EVENTLOG_WARNING_TYPE;
02711           sev = 2;
02712           break;
02713         case SCHEME_LOG_INFO:
02714           ty = EVENTLOG_INFORMATION_TYPE;
02715           sev = 1;
02716           break;
02717         case SCHEME_LOG_DEBUG:
02718         default:
02719           ty = EVENTLOG_AUDIT_SUCCESS;
02720           sev = 0;
02721           break;
02722         }
02723         if (orig_logger->name) {
02724           char *naya;
02725           long slen;
02726           slen = SCHEME_SYM_LEN(orig_logger->name);
02727           naya = (char *)scheme_malloc_atomic(slen + 2 + len + 1);
02728           memcpy(naya, SCHEME_SYM_VAL(orig_logger->name), slen);
02729           memcpy(naya + slen, ": ", 2);
02730           memcpy(naya + slen + 2, buffer, len);
02731           naya[slen + 2 + len] = 0;
02732           buffer = naya;
02733           len += slen + 2;
02734         }
02735         a[0] = buffer;
02736         mzReportEvent(hEventLog, ty, 1 /* category */,
02737                       (sev << 30) | 2 /* message */,
02738                       NULL, 
02739                       1, 0,
02740                       a, NULL);
02741       }
02742 #endif
02743     }
02744     if (logger->stderr_level >= level) {
02745       if (orig_logger->name) {
02746         long slen;
02747         slen = SCHEME_SYM_LEN(orig_logger->name);
02748         fwrite(SCHEME_SYM_VAL(orig_logger->name), slen, 1, stderr);
02749         fwrite(": ", 2, 1, stderr);
02750       }
02751       fwrite(buffer, len, 1, stderr);
02752       fwrite("\n", 1, 1, stderr);
02753     }
02754 
02755     queue = logger->readers;
02756     while (queue) {
02757       b = SCHEME_CAR(queue);
02758       b = SCHEME_CAR(b);
02759       lr = (Scheme_Log_Reader *)SCHEME_BOX_VAL(b);
02760       if (lr) {
02761         if (lr->want_level >= level) {
02762           if (!msg) {
02763             Scheme_Object *v;
02764             msg = scheme_make_vector(3, NULL);
02765             switch (level) {
02766             case SCHEME_LOG_FATAL:
02767               v = fatal_symbol;
02768               break;
02769             case SCHEME_LOG_ERROR:
02770               v = error_symbol;
02771               break;
02772             case SCHEME_LOG_WARNING:
02773               v = warning_symbol;
02774               break;
02775             case SCHEME_LOG_INFO:
02776               v = info_symbol;
02777               break;
02778             case SCHEME_LOG_DEBUG:
02779             default:
02780               v = debug_symbol;
02781               break;
02782             }
02783             SCHEME_VEC_ELS(msg)[0] = v;
02784           
02785             if (orig_logger->name) {
02786               /* Add logger name prefix: */
02787               long slen;
02788               char *cp;
02789               slen = SCHEME_SYM_LEN(orig_logger->name);
02790               cp = scheme_malloc_atomic(slen + len + 2);
02791               memcpy(cp, SCHEME_SYM_VAL(orig_logger->name), slen);
02792               memcpy(cp + slen, ": ", 2);
02793               memcpy(cp + slen + 2, buffer, len + 1);
02794               len += slen + 2;
02795               buffer = cp;
02796             }
02797 
02798             v = scheme_make_sized_utf8_string(buffer, len);
02799             SCHEME_SET_CHAR_STRING_IMMUTABLE(v);
02800             SCHEME_VEC_ELS(msg)[1] = v;
02801             SCHEME_VEC_ELS(msg)[2] = (data ? data : scheme_false);
02802           }
02803           
02804           /* enqueue */
02805           q = scheme_make_raw_pair(msg, NULL);
02806           if (lr->tail)
02807             SCHEME_CDR(lr->tail) = q;
02808           else
02809             lr->head = q;
02810           lr->tail = q;
02811           scheme_post_sema(lr->sema);
02812         }
02813       }
02814       queue = SCHEME_CDR(queue);
02815     }
02816 
02817     logger = logger->parent;
02818   }
02819 }
02820 
02821 void scheme_log_abort(char *buffer)
02822 {
02823   Scheme_Logger logger;
02824   long ts;
02825 
02826   memset(&logger, 0, sizeof(logger));
02827 
02828   logger.name = NULL;
02829   logger.parent = NULL;
02830   logger.want_level = SCHEME_LOG_FATAL;
02831 
02832   ts = 0;
02833   logger.timestamp = &ts;
02834   logger.local_timestamp = ts;
02835   logger.syslog_level = init_syslog_level;
02836   logger.stderr_level = init_stderr_level;
02837 
02838   scheme_log_message(&logger, SCHEME_LOG_FATAL, buffer, strlen(buffer), scheme_false);
02839 }
02840 
02841 static int extract_level(const char *who, int which, int argc, Scheme_Object **argv)
02842 {
02843   Scheme_Object *v;
02844   int level;
02845 
02846   v = argv[which];
02847   if (SAME_OBJ(v, fatal_symbol))
02848     level = SCHEME_LOG_FATAL;
02849   else if (SAME_OBJ(v, error_symbol))
02850     level = SCHEME_LOG_ERROR;
02851   else if (SAME_OBJ(v, warning_symbol))
02852     level = SCHEME_LOG_WARNING;
02853   else if (SAME_OBJ(v, info_symbol))
02854     level = SCHEME_LOG_INFO;
02855   else if (SAME_OBJ(v, debug_symbol))
02856     level = SCHEME_LOG_DEBUG;
02857   else {
02858     scheme_wrong_type(who, "'fatal, 'error, 'warning, 'info, or 'debug", which, argc, argv);
02859     return 0;
02860   }
02861   
02862   return level;
02863 }
02864 
02865 static Scheme_Object *
02866 log_message(int argc, Scheme_Object *argv[])
02867 {
02868   Scheme_Logger *logger;
02869   Scheme_Object *bytes;
02870   int level;
02871 
02872   if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_logger_type))
02873     scheme_wrong_type("log-message", "logger", 0, argc, argv);
02874   logger = (Scheme_Logger *)argv[0];
02875 
02876   level = extract_level("log-message", 1, argc, argv);
02877 
02878   bytes = argv[2];
02879   if (!SCHEME_CHAR_STRINGP(bytes))
02880     scheme_wrong_type("log-message", "string", 2, argc, argv);
02881   bytes = scheme_char_string_to_byte_string(bytes);
02882   
02883   scheme_log_message(logger, level, SCHEME_BYTE_STR_VAL(bytes), SCHEME_BYTE_STRLEN_VAL(bytes), argv[3]);
02884 
02885   return scheme_void;
02886 }
02887 
02888 static Scheme_Object *
02889 log_level_p(int argc, Scheme_Object *argv[])
02890 {
02891   Scheme_Logger *logger;
02892   int level;
02893 
02894   if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_logger_type))
02895     scheme_wrong_type("log-level?", "logger", 0, argc, argv);
02896   logger = (Scheme_Logger *)argv[0];
02897 
02898   level = extract_level("log-level?", 1, argc, argv);
02899 
02900   if (logger->local_timestamp < *logger->timestamp)
02901     update_want_level(logger);
02902 
02903   return ((logger->want_level >= level) ? scheme_true : scheme_false);
02904 }
02905 
02906 static Scheme_Object *
02907 make_logger(int argc, Scheme_Object *argv[])
02908 {
02909   Scheme_Logger *parent;
02910 
02911   if (argc) {
02912     if (!SCHEME_FALSEP(argv[0]) && !SCHEME_SYMBOLP(argv[0]))
02913       scheme_wrong_type("make-logger", "symbol or #f", 0, argc, argv);
02914 
02915     if (argc > 1) {
02916       if (SCHEME_FALSEP(argv[1]))
02917         parent = NULL;
02918       else {
02919         if (!SAME_TYPE(SCHEME_TYPE(argv[1]), scheme_logger_type))
02920           scheme_wrong_type("make-logger", "logger or #f", 1, argc, argv);
02921         parent = (Scheme_Logger *)argv[1];
02922       }
02923     } else
02924       parent = NULL;
02925   } else
02926     parent = NULL;
02927 
02928   return (Scheme_Object *)make_a_logger(parent, 
02929                                         (argc 
02930                                          ? (SCHEME_FALSEP(argv[0]) ? NULL : argv[0])
02931                                          : NULL));
02932 }
02933 
02934 static Scheme_Logger *make_a_logger(Scheme_Logger *parent, Scheme_Object *name)
02935 {
02936   Scheme_Logger *logger;
02937 
02938   logger = MALLOC_ONE_TAGGED(Scheme_Logger);
02939   logger->so.type = scheme_logger_type;
02940   logger->parent = parent;
02941   if (parent) {
02942     logger->timestamp = parent->timestamp;
02943   } else {
02944     long *timestamp;
02945     timestamp = MALLOC_ONE_ATOMIC(long);
02946     *timestamp = 1;
02947     logger->timestamp = timestamp;
02948   }
02949   logger->name = name;
02950 
02951   return logger;
02952 }
02953 
02954 static Scheme_Object *
02955 logger_p(int argc, Scheme_Object *argv[])
02956 {
02957   return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_logger_type)
02958           ? scheme_true
02959           : scheme_false);
02960 }
02961 
02962 static Scheme_Object *
02963 current_logger(int argc, Scheme_Object *argv[])
02964 {
02965   return scheme_param_config("current-logger",
02966                           scheme_make_integer(MZCONFIG_LOGGER),
02967                           argc, argv,
02968                           -1, logger_p, "logger", 0);
02969 }
02970 
02971 static Scheme_Object *
02972 logger_name(int argc, Scheme_Object *argv[])
02973 {
02974   Scheme_Object *name;
02975 
02976   if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_logger_type))
02977     scheme_wrong_type("logger-name", "logger", 0, argc, argv);
02978 
02979   name = ((Scheme_Logger *)argv[0])->name;
02980   return (name ? name : scheme_false);
02981 }
02982 
02983 static Scheme_Object *
02984 make_log_reader(int argc, Scheme_Object *argv[])
02985 {
02986   Scheme_Logger *logger;
02987   Scheme_Log_Reader *lr;
02988   Scheme_Object *sema, *q;
02989   int level;
02990 
02991   if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_logger_type))
02992     scheme_wrong_type("make-log-receiver", "logger", 0, argc, argv);
02993   logger = (Scheme_Logger *)argv[0];
02994 
02995   level = extract_level("make-log-receiver", 1, argc, argv);
02996 
02997   lr = MALLOC_ONE_TAGGED(Scheme_Log_Reader);
02998   lr->so.type = scheme_log_reader_type;
02999   lr->want_level = level;
03000 
03001   sema = scheme_make_sema(0);
03002   lr->sema = sema;
03003 
03004   /* Pair a weak reference to the reader with a strong reference to the
03005      channel. Channel gets are wrapped to reference the reader. That way,
03006      the link is effectively strong while a thread is sync'd on the
03007      reader. */
03008 
03009   q = scheme_make_raw_pair(scheme_make_pair(scheme_make_weak_box((Scheme_Object *)lr), 
03010                                             sema),
03011                            logger->readers);
03012   logger->readers = q;
03013   *logger->timestamp += 1;
03014 
03015   return (Scheme_Object *)lr;
03016 }
03017 
03018 static Scheme_Object *
03019 log_reader_p(int argc, Scheme_Object *argv[])
03020 {
03021   return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_log_reader_type)
03022           ? scheme_true
03023           : scheme_false);
03024 }
03025 
03026 static Scheme_Object *dequeue_log(Scheme_Object *_lr)
03027 {
03028   Scheme_Log_Reader *lr = (Scheme_Log_Reader *)_lr;
03029 
03030   if (lr->head) {
03031     Scheme_Object *v;
03032     v = SCHEME_CAR(lr->head);
03033     lr->head = SCHEME_CDR(lr->head);
03034     if (!lr->head)
03035       lr->tail = NULL;
03036     return v;
03037   } else {
03038     scheme_signal_error("empty log-reader queue!?");
03039     return NULL;
03040   }
03041 }
03042 
03043 static int log_reader_get(Scheme_Object *_lr, Scheme_Schedule_Info *sinfo)
03044 {
03045   Scheme_Log_Reader *lr = (Scheme_Log_Reader *)_lr;
03046   scheme_set_sync_target(sinfo, lr->sema, (Scheme_Object *)lr, NULL, 0, 1, dequeue_log);
03047   return 0;
03048 }
03049 
03050 /***********************************************************************/
03051 
03052 void
03053 scheme_raise_exn(int id, ...)
03054 {
03055   GC_CAN_IGNORE va_list args;
03056   long alen;
03057   char *msg;
03058   int i, c;
03059   Scheme_Object *eargs[MZEXN_MAXARGS];
03060   char *buffer;
03061 
03062   /* Precise GC: Don't allocate before getting hidden args off stack */
03063   HIDE_FROM_XFORM(va_start(args, id));
03064 
03065   if (id == MZEXN_OTHER)
03066     c = 3;
03067   else
03068     c = exn_table[id].args;
03069 
03070   for (i = 2; i < c; i++) {
03071     eargs[i] = mzVA_ARG(args, Scheme_Object*);
03072   }
03073 
03074   msg = mzVA_ARG(args, char*);
03075 
03076   alen = sch_vsprintf(NULL, 0, msg, args, &buffer);
03077   HIDE_FROM_XFORM(va_end(args));
03078 
03079 #ifndef NO_SCHEME_EXNS
03080   eargs[0] = scheme_make_immutable_sized_utf8_string(buffer, alen);
03081   eargs[1] = TMP_CMARK_VALUE;
03082 
03083   do_raise(scheme_make_struct_instance(exn_table[id].type,
03084                                    c, eargs),
03085           1,
03086            1);
03087 #else
03088   call_error(buffer, alen, scheme_false);
03089 #endif
03090 }
03091 
03092 #ifndef NO_SCHEME_EXNS
03093 
03094 static Scheme_Object *
03095 def_exn_handler(int argc, Scheme_Object *argv[])
03096 {
03097   char *s;
03098   int len = -1;
03099 
03100   if (SCHEME_STRUCTP(argv[0])
03101       && scheme_is_struct_instance(exn_table[MZEXN].type, argv[0])) {
03102     Scheme_Object *str = ((Scheme_Structure *)argv[0])->slots[0];
03103     if (SCHEME_CHAR_STRINGP(str)) {
03104       str = scheme_char_string_to_byte_string(str);
03105       s = SCHEME_BYTE_STR_VAL(str);
03106       len = SCHEME_BYTE_STRTAG_VAL(str);
03107     } else
03108       s = "exception raised [message field is not a string]";
03109   } else {
03110     char *v;
03111 
03112     v = scheme_make_provided_string(argv[0], 1, &len);
03113     s = scheme_malloc_atomic(len + 21);
03114     memcpy(s, "uncaught exception: ", 20);
03115     memcpy(s + 20, v, len + 1);
03116     len += 20;
03117   }
03118 
03119   call_error(s, len, argv[0]);
03120 
03121   return scheme_void;
03122 }
03123 
03124 static Scheme_Object *
03125 init_exn_handler(int argc, Scheme_Object *argv[])
03126 {
03127   return scheme_param_config("uncaught-exception-handler",
03128                           scheme_make_integer(MZCONFIG_INIT_EXN_HANDLER),
03129                           argc, argv,
03130                           1, NULL, NULL, 0);
03131 }
03132 
03133 static Scheme_Object *
03134 nested_exn_handler(void *old_exn, int argc, Scheme_Object *argv[])
03135 {
03136   Scheme_Object *arg = argv[0], *orig_arg = SCHEME_CDR((Scheme_Object *)old_exn);
03137   long len, mlen = -1, orig_mlen = -1, blen;
03138   char *buffer, *msg, *orig_msg, *raisetype, *orig_raisetype, *who, *sep;
03139   
03140   buffer = init_buf(&len, &blen);
03141 
03142   if (SCHEME_FALSEP(SCHEME_CAR((Scheme_Object *)old_exn))) {
03143     raisetype = "";
03144     sep = "";
03145     who = "handler for uncaught exceptions";
03146     msg = "did not escape";
03147   } else {
03148     who = SCHEME_BYTE_STR_VAL(SCHEME_CAR((Scheme_Object *)old_exn));
03149     sep = " by ";
03150 
03151     if (SCHEME_STRUCTP(arg)
03152         && scheme_is_struct_instance(exn_table[MZEXN].type, arg)) {
03153       Scheme_Object *str = ((Scheme_Structure *)arg)->slots[0];
03154       raisetype = "exception raised";
03155       str = scheme_char_string_to_byte_string(str);
03156       msg = SCHEME_BYTE_STR_VAL(str);
03157       mlen = SCHEME_BYTE_STRLEN_VAL(str);
03158     } else {
03159       msg = error_write_to_string_w_max(arg, len, NULL);
03160       raisetype = "raise called (with non-exception value)";
03161     }
03162   }
03163 
03164   if (SCHEME_STRUCTP(orig_arg)
03165       && scheme_is_struct_instance(exn_table[MZEXN].type, orig_arg)) {
03166     Scheme_Object *str = ((Scheme_Structure *)orig_arg)->slots[0];
03167     orig_raisetype = "exception raised";
03168     str = scheme_char_string_to_byte_string(str);
03169     orig_msg = SCHEME_BYTE_STR_VAL(str);
03170     orig_mlen = SCHEME_BYTE_STRLEN_VAL(str);
03171   } else {
03172     orig_msg = error_write_to_string_w_max(orig_arg, len, NULL);
03173     orig_raisetype = "raise called (with non-exception value)";
03174   }
03175 
03176 
03177   blen = scheme_sprintf(buffer, blen, "%s%s%s: %t; original %s: %t",
03178                      raisetype, sep, who,
03179                      msg, mlen,
03180                      orig_raisetype,
03181                      orig_msg, orig_mlen);
03182     
03183   call_error(buffer, blen, scheme_false);
03184 
03185   return scheme_void;
03186 }
03187 
03188 static void *do_raise_inside_barrier(void)
03189 {
03190   Scheme_Object *arg;
03191   Scheme_Object *v, *p[1], *h, *marks;
03192   Scheme_Cont_Mark_Chain *chain;
03193   Scheme_Cont_Frame_Data cframe, cframe2;
03194   int got_chain;
03195 
03196   arg = scheme_current_thread->ku.k.p1;
03197   scheme_current_thread->ku.k.p1 = NULL;
03198 
03199   h = scheme_extract_one_cc_mark(NULL, scheme_exn_handler_key);
03200 
03201   chain = NULL;
03202   got_chain = 0;
03203 
03204   while (1) {
03205     if (!h) {
03206       h = scheme_get_param(scheme_current_config(), MZCONFIG_INIT_EXN_HANDLER);
03207       chain = NULL;
03208       got_chain = 1;
03209     }
03210 
03211     v = scheme_make_byte_string_without_copying("exception handler");
03212     v = scheme_make_closed_prim_w_arity(nested_exn_handler,
03213                                         scheme_make_pair(v, arg),
03214                                         "nested-exception-handler", 
03215                                         1, 1);
03216 
03217     scheme_push_continuation_frame(&cframe);
03218     scheme_set_cont_mark(scheme_exn_handler_key, v);
03219     scheme_push_break_enable(&cframe2, 0, 0);
03220 
03221     p[0] = arg;
03222     v = _scheme_apply(h, 1, p);
03223 
03224     scheme_pop_break_enable(&cframe2, 0);
03225     scheme_pop_continuation_frame(&cframe);
03226 
03227     /* Getting a value back means that we should chain to the
03228        next exception handler; we supply the returned value to
03229        the next exception handler (if any). */
03230     if (!got_chain) {
03231       marks = scheme_all_current_continuation_marks();
03232       chain = ((Scheme_Cont_Mark_Set *)marks)->chain;
03233       marks = NULL;
03234       /* Init chain to position of the handler we just
03235          called. */
03236       while (chain->key != scheme_exn_handler_key) {
03237         chain = chain->next;
03238       }
03239       got_chain = 1;
03240     }
03241 
03242     if (chain) {
03243       chain = chain->next;
03244       while (chain && (chain->key != scheme_exn_handler_key)) {
03245         chain = chain->next;
03246       }
03247 
03248       if (!chain)
03249         h = NULL; /* use uncaught handler */
03250       else
03251         h = chain->val;
03252       arg = v;
03253     } else {
03254       /* return from uncaught-exception handler */
03255       p[0] = scheme_false;
03256       return nested_exn_handler(scheme_make_pair(scheme_false, arg), 1, p);
03257     }
03258   }
03259 
03260   return scheme_void;
03261 }
03262 
03263 static Scheme_Object *
03264 do_raise(Scheme_Object *arg, int need_debug, int eb)
03265 {
03266   Scheme_Thread *p = scheme_current_thread;
03267 
03268   if (p->constant_folding) {
03269     if (SCHEME_TRUEP(p->constant_folding)) {
03270       const char *msg;
03271       if (need_debug) {
03272         msg = scheme_display_to_string(((Scheme_Structure *)arg)->slots[0], NULL);
03273       } else
03274         msg = scheme_write_to_string(arg, NULL);
03275       scheme_log(NULL,
03276                  SCHEME_LOG_WARNING,
03277                  0,
03278                  "warning%s: optimizer constant-fold attempt failed: %s",
03279                  scheme_optimize_context_to_string(p->constant_folding),
03280                  msg);
03281     }
03282     if (SCHEME_STRUCTP(arg)
03283         && scheme_is_struct_instance(exn_table[MZEXN_BREAK].type, arg)) {
03284       /* remember to re-raise exception */
03285       scheme_current_thread->reading_delayed = arg;
03286     }
03287     scheme_longjmp (scheme_error_buf, 1);
03288   }
03289   
03290   if (need_debug) {
03291     Scheme_Object *marks;
03292     marks = scheme_current_continuation_marks(NULL);
03293     ((Scheme_Structure *)arg)->slots[1] = marks;
03294   }
03295 
03296   p->ku.k.p1 = arg;
03297 
03298   if (eb)
03299     return (Scheme_Object *)scheme_top_level_do(do_raise_inside_barrier, 1);
03300   else
03301     return (Scheme_Object *)do_raise_inside_barrier();
03302 }
03303 
03304 static Scheme_Object *
03305 sch_raise(int argc, Scheme_Object *argv[])
03306 {
03307   if ((argc > 1) && SCHEME_FALSEP(argv[1]))
03308     return do_raise(argv[0], 0, 0);
03309   else
03310     return do_raise(argv[0], 0, 1);
03311 }
03312 
03313 void scheme_raise(Scheme_Object *exn)
03314 {
03315   do_raise(exn, 0, 1);
03316 }
03317 
03318 typedef Scheme_Object (*Scheme_Struct_Field_Guard_Proc)(int argc, Scheme_Object *v);
03319 
03320 static Scheme_Object *exn_field_check(int argc, Scheme_Object **argv)
03321 {
03322   Scheme_Object *a[2], *v;
03323 
03324   if (!SCHEME_CHAR_STRINGP(argv[0]))
03325     scheme_wrong_field_type(argv[2], "string", argv[0]);
03326   if (!SAME_OBJ(argv[1], TMP_CMARK_VALUE) && !SCHEME_CONT_MARK_SETP(argv[1]))
03327     scheme_wrong_field_type(argv[2], "continuation mark set", argv[1]);
03328 
03329   a[0] = argv[0];
03330   a[1] = argv[1];
03331   
03332   if (!SCHEME_IMMUTABLE_CHAR_STRINGP(a[0])) {
03333     v = scheme_make_immutable_sized_char_string(SCHEME_CHAR_STR_VAL(a[0]),
03334                                                 SCHEME_CHAR_STRLEN_VAL(a[0]),
03335                                                 1);
03336     a[0] = v;
03337   }
03338 
03339   return scheme_values(2, a);
03340 }
03341 
03342 static Scheme_Object *variable_field_check(int argc, Scheme_Object **argv)
03343 {
03344   if (!SCHEME_SYMBOLP(argv[2]))
03345     scheme_wrong_field_type(argv[3], "symbol", argv[2]);
03346 
03347   return scheme_values(3, argv);
03348 }
03349 
03350 static Scheme_Object *syntax_field_check(int argc, Scheme_Object **argv)
03351 {
03352   Scheme_Object *l;
03353 
03354   l = argv[2];
03355   while (SCHEME_PAIRP(l)) {
03356     if (!SCHEME_STXP(SCHEME_CAR(l)))
03357       break;
03358     l = SCHEME_CDR(l);
03359   }
03360 
03361   if (!SCHEME_NULLP(l))
03362     scheme_wrong_field_type(argv[3], "list of syntax objects", argv[2]);
03363 
03364   return scheme_values(3, argv);
03365 }
03366 
03367 static Scheme_Object *read_field_check(int argc, Scheme_Object **argv)
03368 {
03369   Scheme_Object *l;
03370 
03371   l = argv[2];
03372   while (SCHEME_PAIRP(l)) {
03373     if (!scheme_is_location(SCHEME_CAR(l)))
03374       break;
03375     l = SCHEME_CDR(l);
03376   }
03377 
03378   if (!SCHEME_NULLP(l))
03379     scheme_wrong_field_type(argv[3], "list of locations", argv[2]);
03380 
03381   return scheme_values(3, argv);
03382 }
03383 
03384 static Scheme_Object *break_field_check(int argc, Scheme_Object **argv)
03385 {
03386   if (!SCHEME_ECONTP(argv[2]))
03387     scheme_wrong_field_type(argv[3], "escape continuation", argv[2]);
03388 
03389   return scheme_values(3, argv);
03390 }
03391 
03392 static Scheme_Object *extract_syntax_locations(int argc, Scheme_Object **argv)
03393 {
03394   if (scheme_is_struct_instance(exn_table[MZEXN_FAIL_SYNTAX].type, argv[0])) {
03395     Scheme_Object *stxs, *stx, *first = scheme_null, *last = NULL, *loco, *p;
03396     Scheme_Stx_Srcloc *loc;
03397     stxs = scheme_struct_ref(argv[0], 2);
03398     while (SCHEME_PAIRP(stxs)) {
03399       stx = SCHEME_CAR(stxs);
03400       loc = ((Scheme_Stx *)stx)->srcloc;
03401       loco = scheme_make_location(loc->src ? loc->src : scheme_false,
03402                               (loc->line >= 0) ? scheme_make_integer(loc->line) : scheme_false,
03403                               (loc->col >= 0) ? scheme_make_integer(loc->col-1) : scheme_false,
03404                               (loc->pos >= 0) ? scheme_make_integer(loc->pos) : scheme_false,
03405                               (loc->span >= 0) ? scheme_make_integer(loc->span) : scheme_false);
03406       p = scheme_make_pair(loco, scheme_null);
03407       if (last)
03408        SCHEME_CDR(last) = p;
03409       else
03410        first = p;
03411       last = p;
03412       stxs = SCHEME_CDR(stxs);
03413     }
03414     return first;
03415   }
03416   scheme_wrong_type("exn:fail:syntax-locations-accessor", "exn:fail:syntax", 0, argc, argv);
03417   return NULL;
03418 }
03419 
03420 static Scheme_Object *extract_read_locations(int argc, Scheme_Object **argv)
03421 {
03422   if (scheme_is_struct_instance(exn_table[MZEXN_FAIL_READ].type, argv[0]))
03423     return scheme_struct_ref(argv[0], 2);
03424   scheme_wrong_type("exn:fail:read-locations-accessor", "exn:fail:read", 0, argc, argv);
03425   return NULL;
03426 }
03427 
03428 void scheme_init_exn(Scheme_Env *env)
03429 {
03430   int i, j;
03431   Scheme_Object *tmpo, **tmpop;
03432 
03433 #define _MZEXN_DECL_FIELDS
03434 # include "schexn.h"
03435 #undef _MZEXN_DECL_FIELDS
03436 #define _MZEXN_DECL_PROPS
03437 # include "schexn.h"
03438 #undef _MZEXN_DECL_PROPS
03439 
03440   REGISTER_SO(exn_table);
03441 
03442 #ifdef MEMORY_COUNTING_ON
03443 # ifndef GLOBAL_EXN_TABLE
03444   scheme_misc_count += (sizeof(exn_rec) * MZEXN_OTHER);
03445 # endif
03446 #endif
03447 
03448 #define _MZEXN_PRESETUP
03449 # include "schexn.h"
03450 #undef _MZEXN_PRESETUP
03451 
03452 #define EXN_PARENT(id) exn_table[id].type
03453 
03454 #define EXN_FLAGS SCHEME_STRUCT_EXPTIME | SCHEME_STRUCT_NO_SET
03455 
03456 #define SETUP_STRUCT(id, parent, name, argc, args, props, guard) \
03457     { tmpo = scheme_make_struct_type_from_string(name, parent, argc, props, guard, 1); \
03458       exn_table[id].type = tmpo; \
03459       tmpop = scheme_make_struct_names_from_array(name, argc, args, EXN_FLAGS, &exn_table[id].count); \
03460       exn_table[id].names = tmpop; }
03461 
03462 #define EXNCONS scheme_make_pair
03463 #define _MZEXN_SETUP
03464 #include "schexn.h"
03465 
03466   for (i = 0; i < MZEXN_OTHER; i++) {
03467     if (exn_table[i].count) {
03468       Scheme_Object **values, *et;
03469       int sp;
03470 
03471       values = scheme_make_struct_values(exn_table[i].type,
03472                                     exn_table[i].names,
03473                                     exn_table[i].count,
03474                                     EXN_FLAGS);
03475       for (j = exn_table[i].count - 1; j--; ) {
03476        scheme_add_global_constant_symbol(exn_table[i].names[j],
03477                                      values[j],
03478                                      env);
03479       }
03480 
03481       sp = exn_table[i].super_pos;
03482       et = scheme_make_struct_exptime(exn_table[i].names, exn_table[i].count,
03483                                   (sp >= 0) ? exn_table[sp].names[exn_table[sp].count - 1] : NULL,
03484                                   (sp >= 0) ? exn_table[sp].exptime : NULL,
03485                                   EXN_FLAGS);
03486       exn_table[i].exptime = et;
03487       scheme_add_global_keyword_symbol(exn_table[i].names[exn_table[i].count - 1], et, env);
03488     }
03489   }
03490 
03491   scheme_add_global_constant("uncaught-exception-handler",
03492                           scheme_register_parameter(init_exn_handler,
03493                                                  "uncaught-exception-handler",
03494                                                  MZCONFIG_INIT_EXN_HANDLER),
03495                           env);
03496 
03497   scheme_add_global_constant("raise",
03498                           scheme_make_noncm_prim(sch_raise,
03499                                                     "raise",
03500                                                     1, 2),
03501                           env);
03502 
03503   scheme_init_exn_config();
03504 }
03505 
03506 void scheme_init_exn_config(void)
03507 {
03508   Scheme_Object *h;
03509 
03510   h = scheme_make_prim_w_arity(def_exn_handler, "default-exception-handler", 1, 1);
03511 
03512   scheme_set_root_param(MZCONFIG_INIT_EXN_HANDLER, h);
03513 }
03514 
03515 #endif