PageRenderTime 148ms CodeModel.GetById 44ms app.highlight 87ms RepoModel.GetById 1ms app.codeStats 1ms

/racket/src/racket/src/error.c

http://github.com/plt/racket
C | 4799 lines | 3963 code | 691 blank | 145 comment | 755 complexity | 6e62fdbbfda041ed054b7145fcf94e8b MD5 | raw file

Large files files are truncated, but you can click here to view the full file

   1#include "schpriv.h"
   2#include "schrktio.h"
   3#include <ctype.h>
   4#ifdef DOS_FILE_SYSTEM
   5# include <windows.h>
   6#endif
   7#ifdef NO_ERRNO_GLOBAL
   8# define errno -1
   9#else
  10# include <errno.h>
  11#endif
  12
  13#define mzVA_ARG(x, y) HIDE_FROM_XFORM(va_arg(x, y))
  14#define TMP_CMARK_VALUE scheme_parameterization_key
  15
  16#ifndef INIT_SYSLOG_LEVEL
  17# define INIT_SYSLOG_LEVEL 0
  18#endif
  19
  20/* globals */
  21SHARED_OK scheme_console_printf_t scheme_console_printf;
  22scheme_console_printf_t scheme_get_console_printf() { return scheme_console_printf; }
  23void scheme_set_console_printf(scheme_console_printf_t p) { scheme_console_printf = p; }
  24SHARED_OK Scheme_Exit_Proc scheme_exit;
  25void scheme_set_exit(Scheme_Exit_Proc p) { scheme_exit = p; }
  26
  27HOOK_SHARED_OK void (*scheme_console_output)(char *str, intptr_t len);
  28void scheme_set_console_output(scheme_console_output_t p) { scheme_console_output = p; }
  29
  30SHARED_OK static Scheme_Object *init_syslog_level = scheme_make_integer(INIT_SYSLOG_LEVEL);
  31SHARED_OK static Scheme_Object *init_stderr_level = scheme_make_integer(SCHEME_LOG_ERROR);
  32SHARED_OK static Scheme_Object *init_stdout_level = scheme_make_integer(0);
  33THREAD_LOCAL_DECL(static Scheme_Logger *scheme_main_logger);
  34THREAD_LOCAL_DECL(static Scheme_Logger *scheme_gc_logger);
  35THREAD_LOCAL_DECL(static Scheme_Logger *scheme_future_logger);
  36THREAD_LOCAL_DECL(static Scheme_Logger *scheme_place_logger);
  37
  38/* readonly globals */
  39ROSYM static Scheme_Object *none_symbol;
  40ROSYM static Scheme_Object *fatal_symbol;
  41ROSYM static Scheme_Object *error_symbol; 
  42ROSYM static Scheme_Object *warning_symbol;
  43ROSYM static Scheme_Object *info_symbol;
  44ROSYM static Scheme_Object *debug_symbol;
  45ROSYM static Scheme_Object *posix_symbol;
  46ROSYM static Scheme_Object *windows_symbol;
  47ROSYM static Scheme_Object *gai_symbol;
  48ROSYM static Scheme_Object *arity_property;
  49ROSYM static Scheme_Object *def_err_val_proc;
  50ROSYM static Scheme_Object *def_error_esc_proc;
  51ROSYM static Scheme_Object *default_display_handler;
  52ROSYM static Scheme_Object *emergency_display_handler;
  53ROSYM static Scheme_Object *def_exe_yield_proc;
  54READ_ONLY Scheme_Object *scheme_def_exit_proc;
  55READ_ONLY Scheme_Object *scheme_raise_arity_error_proc;
  56
  57#ifdef MEMORY_COUNTING_ON
  58intptr_t scheme_misc_count;
  59#endif
  60
  61#ifdef MZ_USE_MZRT
  62static mzrt_mutex *glib_log_queue_lock;
  63typedef struct glib_log_queue_entry {
  64  const char *log_domain;
  65  int log_level;
  66  const char *message;
  67  struct glib_log_queue_entry *next;
  68} glib_log_queue_entry;
  69static glib_log_queue_entry *glib_log_queue;
  70static void *glib_log_signal_handle;
  71#endif
  72
  73/* locals */
  74static Scheme_Object *error(int argc, Scheme_Object *argv[]);
  75static Scheme_Object *raise_user_error(int argc, Scheme_Object *argv[]);
  76static Scheme_Object *raise_type_error(int argc, Scheme_Object *argv[]);
  77static Scheme_Object *raise_argument_error(int argc, Scheme_Object *argv[]);
  78static Scheme_Object *raise_result_error(int argc, Scheme_Object *argv[]);
  79static Scheme_Object *raise_mismatch_error(int argc, Scheme_Object *argv[]);
  80static Scheme_Object *raise_arguments_error(int argc, Scheme_Object *argv[]);
  81static Scheme_Object *raise_range_error(int argc, Scheme_Object *argv[]);
  82static Scheme_Object *raise_arity_error(int argc, Scheme_Object *argv[]);
  83static Scheme_Object *raise_arity_mask_error(int argc, Scheme_Object *argv[]);
  84static Scheme_Object *raise_result_arity_error(int argc, Scheme_Object *argv[]);
  85static Scheme_Object *error_escape_handler(int, Scheme_Object *[]);
  86static Scheme_Object *error_display_handler(int, Scheme_Object *[]);
  87static Scheme_Object *error_value_string_handler(int, Scheme_Object *[]);
  88static Scheme_Object *exit_handler(int, Scheme_Object *[]);
  89static Scheme_Object *exe_yield_handler(int, Scheme_Object *[]);
  90static Scheme_Object *error_print_width(int, Scheme_Object *[]);
  91static Scheme_Object *error_print_context_length(int, Scheme_Object *[]);
  92static Scheme_Object *error_print_srcloc(int, Scheme_Object *[]);
  93static MZ_NORETURN void def_error_escape_proc(int, Scheme_Object *[]);
  94static Scheme_Object *def_error_display_proc(int, Scheme_Object *[]);
  95static Scheme_Object *emergency_error_display_proc(int, Scheme_Object *[]);
  96static Scheme_Object *def_error_value_string_proc(int, Scheme_Object *[]);
  97static Scheme_Object *def_exit_handler_proc(int, Scheme_Object *[]);
  98static Scheme_Object *default_yield_handler(int, Scheme_Object *[]);
  99static Scheme_Object *srcloc_to_string(int argc, Scheme_Object **argv);
 100static Scheme_Object *unquoted_printing_string(int argc, Scheme_Object **argv);
 101static Scheme_Object *unquoted_printing_string_p(int argc, Scheme_Object **argv);
 102static Scheme_Object *unquoted_printing_string_value(int argc, Scheme_Object **argv);
 103
 104static Scheme_Object *log_message(int argc, Scheme_Object *argv[]);
 105static Scheme_Object *log_level_p(int argc, Scheme_Object *argv[]);
 106static Scheme_Object *log_max_level(int argc, Scheme_Object *argv[]);
 107static Scheme_Object *log_all_levels(int argc, Scheme_Object *argv[]);
 108static Scheme_Object *log_level_evt(int argc, Scheme_Object *argv[]);
 109static Scheme_Object *make_logger(int argc, Scheme_Object *argv[]);
 110static Scheme_Object *logger_p(int argc, Scheme_Object *argv[]);
 111static Scheme_Object *current_logger(int argc, Scheme_Object *argv[]);
 112static Scheme_Object *logger_name(int argc, Scheme_Object *argv[]);
 113static Scheme_Object *make_log_reader(int argc, Scheme_Object *argv[]);
 114static Scheme_Object *log_reader_p(int argc, Scheme_Object *argv[]);
 115static int log_reader_get(Scheme_Object *ch, Scheme_Schedule_Info *sinfo);
 116
 117static MZ_NORETURN void do_raise(Scheme_Object *arg, int need_debug, int barrier);
 118static MZ_NORETURN void nested_exn_handler(void *old_exn, int argc, Scheme_Object *argv[]);
 119
 120static void update_want_level(Scheme_Logger *logger, Scheme_Object *name);
 121
 122static Scheme_Object *check_arity_property_value_ok(int argc, Scheme_Object *argv[]);
 123
 124static char *make_provided_list(Scheme_Object *o, int count, intptr_t *lenout);
 125
 126static char *init_buf(intptr_t *len, intptr_t *blen);
 127
 128void scheme_set_logging2(int syslog_level, int stderr_level, int stdout_level)
 129{
 130  if (syslog_level > -1)
 131    init_syslog_level = scheme_make_integer(syslog_level);
 132  if (stderr_level > -1)
 133    init_stderr_level = scheme_make_integer(stderr_level);
 134  if (stdout_level > -1)
 135    init_stdout_level = scheme_make_integer(stdout_level);
 136}
 137
 138void scheme_set_logging(int syslog_level, int stderr_level)
 139{
 140  scheme_set_logging2(syslog_level, stderr_level, -1);
 141}
 142  
 143void scheme_set_logging2_spec(Scheme_Object *syslog_level, Scheme_Object *stderr_level, Scheme_Object *stdout_level)
 144{
 145  /* A spec is (list* <int> <byte-string> .... <int>) */
 146  if (syslog_level) {
 147    REGISTER_SO(init_syslog_level);
 148    init_syslog_level = syslog_level;
 149  }
 150  if (stderr_level) {
 151    REGISTER_SO(init_stderr_level);
 152    init_stderr_level = stderr_level;
 153  }
 154  if (stdout_level) {
 155    REGISTER_SO(init_stdout_level);
 156    init_stdout_level = stdout_level;
 157  }
 158}
 159
 160void scheme_set_logging_spec(Scheme_Object *syslog_level, Scheme_Object *stderr_level)
 161{
 162  scheme_set_logging2_spec(syslog_level, stderr_level, NULL);
 163}
 164
 165void scheme_init_logging_once(void)
 166{
 167  /* Convert specs to use symbols */
 168  int j;
 169  Scheme_Object *l, *s;
 170
 171  for (j = 0; j < 3; j++) {
 172    switch (j) {
 173    case 0: l = init_syslog_level; break;
 174    case 1: l = init_stderr_level; break;
 175    default: l = init_stdout_level; break;
 176    }
 177    if (l) {
 178      while (!SCHEME_INTP(l)) {
 179        l = SCHEME_CDR(l);
 180        s = scheme_intern_exact_symbol(SCHEME_BYTE_STR_VAL(SCHEME_CAR(l)),
 181                                       SCHEME_BYTE_STRLEN_VAL(SCHEME_CAR(l)));
 182        SCHEME_CAR(l) = s;
 183        l = SCHEME_CDR(l);
 184      }
 185    }
 186  }
 187}
 188
 189typedef struct {
 190  int args;
 191  Scheme_Object *type;
 192  Scheme_Object **names;
 193  int count;
 194  Scheme_Object *exptime;
 195  int super_pos;
 196} exn_rec;
 197
 198#define _MZEXN_TABLE
 199#include "schexn.h"
 200#undef _MZEXN_TABLE
 201
 202static void default_printf(char *msg, ...)
 203{
 204  GC_CAN_IGNORE va_list args;
 205  HIDE_FROM_XFORM(va_start(args, msg));
 206  vfprintf(stderr, msg, args);
 207  HIDE_FROM_XFORM(va_end(args));
 208  fflush(stderr);
 209}
 210
 211static void default_output(char *s, intptr_t len)
 212{
 213  fwrite(s, len, 1, stderr);
 214  fflush(stderr);
 215}
 216
 217intptr_t scheme_errno() {
 218#ifdef WINDOWS_FILE_HANDLES
 219  return GetLastError();
 220#else
 221  return errno;
 222#endif
 223}
 224
 225Scheme_Config *scheme_init_error_escape_proc(Scheme_Config *config)
 226{
 227  if (!def_error_esc_proc) {
 228    REGISTER_SO(def_error_esc_proc);
 229    def_error_esc_proc =
 230      scheme_make_prim_w_arity((Scheme_Prim *)def_error_escape_proc,
 231			       "default-error-escape-handler",
 232			       0, 0);
 233  }
 234
 235  if (config)
 236    return scheme_extend_config(config, MZCONFIG_ERROR_ESCAPE_HANDLER, def_error_esc_proc);
 237  else {
 238    scheme_set_root_param(MZCONFIG_ERROR_ESCAPE_HANDLER, def_error_esc_proc);
 239    return NULL;
 240  }
 241}
 242
 243/*
 244  Recognized by scheme_[v]sprintf:
 245
 246  %c = unicode char
 247  %d = int
 248  %gd = long int
 249  %gx = long int
 250  %ld = intptr_t
 251  %Id = intptr_t (for MSVC)
 252  %I64d = intptr_t (for MingGW)
 253  %lx = intptr_t
 254  %Ix = intptr_t (for MSVC)
 255  %I64x = intptr_t (for MingGW)
 256  %o = int, octal
 257  %f = double
 258  %% = percent
 259
 260  %s = string
 261  %5 = mzchar string
 262  %S = Scheme symbol
 263  %t = string with inptr_t size
 264  %u = mzchar string with intptr_t size
 265  %T = Scheme string
 266  %q = truncated-to-256 string
 267  %Q = truncated-to-256 Scheme string
 268  %V = scheme_value
 269  %@ = list of scheme_value to write splice
 270  %D = scheme value to display
 271  %W = scheme value to write
 272  %_ = skip pointer
 273  %- = skip int
 274
 275  %L = line number as intptr_t, -1 means no line
 276  %R = get error number and string from rktio
 277  %e = error number for strerror()
 278  %E = error number for platform-specific error string
 279  %Z = potential platform-specific error number; additional char*
 280       is either NULL or a specific error message
 281  %N = boolean then error number like %E (if boolean is 0)
 282       or error number for scheme_hostname_error()
 283  %m = boolean then error number like %e, which
 284       is used only if the boolean is 1
 285  %M = boolean then error number like %E, which
 286       is used only if the boolean is 1
 287*/
 288
 289static intptr_t sch_vsprintf(char *s, intptr_t maxlen, const char *msg, va_list args, char **_s,
 290                             Scheme_Object **_errno_val, int *_unsupported)
 291/* NULL for s means allocate the buffer here (and return in (_s), but this function 
 292   doesn't allocate before extracting arguments from the stack. */
 293{
 294  intptr_t i, j;
 295  char buf[100];
 296
 297  /* Since we might malloc, move all pointers into a local array for
 298     the sake of precise GC. We have to do numbers, too, for
 299     consistency. */
 300
 301  int pp = 0, ip = 0, dp = 0;
 302  void *ptrs[25];
 303  intptr_t ints[25];
 304  double dbls[25];
 305
 306  for (j = 0; msg[j]; j++) {
 307    if (msg[j] == '%') {
 308      int type;
 309
 310      j++;
 311      type = msg[j];
 312
 313      switch (type) {
 314      case 'c':
 315	ints[ip++] = mzVA_ARG(args, int);
 316	break;
 317      case 'd':
 318      case 'o':
 319      case '-':
 320	ints[ip++] = mzVA_ARG(args, int);
 321	break;
 322      case 'g':
 323	ints[ip++] = mzVA_ARG(args, long);
 324	break;
 325      case 'l':
 326      case 'I':
 327	ints[ip++] = mzVA_ARG(args, intptr_t);
 328	break;
 329      case 'f':
 330	dbls[dp++] = mzVA_ARG(args, double);
 331	break;
 332      case 'L':
 333	ints[ip++] = mzVA_ARG(args, intptr_t);
 334	break;
 335      case 'e':
 336      case 'E':
 337	ints[ip++] = mzVA_ARG(args, int);
 338	break;
 339      case 'N':
 340      case 'm':
 341      case 'M':
 342	ints[ip++] = mzVA_ARG(args, int);
 343	ints[ip++] = mzVA_ARG(args, int);
 344	break;
 345      case 'Z':
 346	ints[ip++] = mzVA_ARG(args, int);
 347	ptrs[pp++] = mzVA_ARG(args, char*);
 348	break;
 349      case 'S':
 350      case 'V':
 351      case '@':
 352      case 'D':
 353      case 'W':
 354      case 'T':
 355      case 'Q':
 356      case '_':
 357	ptrs[pp++] = mzVA_ARG(args, Scheme_Object*);
 358	break;
 359      default:
 360	ptrs[pp++] = mzVA_ARG(args, char*);
 361	if ((type == 't') || (type == 'u')) {
 362	  ints[ip++] = mzVA_ARG(args, intptr_t);
 363	}
 364      }
 365    }
 366  }
 367  pp = 0;
 368  ip = 0;
 369  dp = 0;
 370
 371  if (!s) {
 372    s = init_buf(NULL, &maxlen);
 373    *_s = s;
 374  }
 375
 376  --maxlen;
 377
 378  i = j = 0;
 379  while ((i < maxlen) && msg[j]) {
 380    if (msg[j] == '%') {
 381      int type;
 382
 383      j++;
 384      type = msg[j++];
 385
 386      if (type == '%')
 387	s[i++] = '%';
 388      else {
 389	const char *t;
 390	intptr_t tlen;
 391	int dots = 0;
 392
 393	switch (type) {
 394	case 'c':
 395	  {
 396	    int c;
 397	    c = ints[ip++];
 398	    if (c < 128) {
 399	      buf[0] = c;
 400	      tlen = 1;
 401	    } else {
 402	      mzchar mc;
 403              mc = c;
 404	      tlen = scheme_utf8_encode_all(&mc, 1, (unsigned char *)buf);
 405	    }
 406	    t = buf;
 407	  }
 408	  break;
 409	case 'd':
 410	  {
 411	    int d;
 412	    d = ints[ip++];
 413	    sprintf(buf, "%d", d);
 414	    t = buf;
 415	    tlen = strlen(t);
 416	  }
 417	  break;
 418	case '-':
 419	  {
 420	    ip++;
 421	    t = "";
 422	    tlen = 0;
 423	  }
 424	  break;
 425	case 'o':
 426	  {
 427	    int d;
 428	    d = ints[ip++];
 429	    sprintf(buf, "%o", d);
 430	    t = buf;
 431	    tlen = strlen(t);
 432	  }
 433	  break;
 434	case 'I':
 435	case 'l':
 436	case 'g':
 437	  {
 438	    intptr_t d;
 439            int as_hex;
 440            if ((type == 'I') && (msg[j] == '6') && (msg[j+1] == '4'))
 441              j++;
 442            as_hex = (msg[j] == 'x');
 443	    j++;
 444	    d = ints[ip++];
 445            if (as_hex)
 446              sprintf(buf, "%" PRIxPTR, d);
 447            else
 448              sprintf(buf, "%" PRIdPTR, d);
 449	    t = buf;
 450	    tlen = strlen(t);
 451	  }
 452	  break;
 453	case 'f':
 454	  {
 455	    double f;
 456	    f = dbls[dp++];
 457	    sprintf(buf, "%f", f);
 458	    t = buf;
 459	    tlen = strlen(t);
 460	  }
 461	  break;
 462	case 'L':
 463	  {
 464	    intptr_t d;
 465	    d = ints[ip++];
 466	    if (d >= 0) {
 467	      sprintf(buf, "%" PRIdPTR ":", d);
 468	      t = buf;
 469	      tlen = strlen(t);
 470	    } else {
 471	      t = ":";
 472	      tlen = 1;
 473	    }
 474	  }
 475	  break;
 476        case 'R':
 477          {
 478            intptr_t errid;
 479            intptr_t errkind;
 480            const char *es, *errkind_str;
 481            intptr_t elen;
 482            errkind = rktio_get_last_error_kind(scheme_rktio);
 483            errid = rktio_get_last_error(scheme_rktio);
 484            switch (errkind) {
 485            case RKTIO_ERROR_KIND_WINDOWS:
 486              errkind_str = "errid";
 487              break;
 488            case RKTIO_ERROR_KIND_POSIX:
 489              errkind_str = "errno";
 490              break;
 491            case RKTIO_ERROR_KIND_GAI:
 492              errkind_str = "gai_err";
 493              break;
 494            default:
 495              errkind_str = "rktio_err";
 496              break;
 497            }
 498            es = rktio_get_error_string(scheme_rktio, errkind, errid);
 499            sprintf(buf, "; %s=%" PRIdPTR "", errkind_str, errid);
 500            if (es) elen = strlen(es); else elen = 0;
 501            tlen = strlen(buf);
 502            t = (const char *)scheme_malloc_atomic(tlen+elen+1);
 503            memcpy((char *)t, es, elen);
 504            memcpy((char *)t+elen, buf, tlen+1);
 505            tlen += elen;
 506            if (_errno_val) {
 507              Scheme_Object *err_kind;
 508              switch (errkind) {
 509              case RKTIO_ERROR_KIND_WINDOWS:
 510                err_kind = windows_symbol;
 511                break;
 512              case RKTIO_ERROR_KIND_POSIX:
 513                err_kind = posix_symbol;
 514                break;
 515              case RKTIO_ERROR_KIND_GAI:
 516                err_kind = gai_symbol;
 517                break;
 518              default:
 519                err_kind = NULL;
 520              }
 521              if (err_kind) {
 522                err_kind = scheme_make_pair(scheme_make_integer_value(errid), err_kind);
 523                *_errno_val = err_kind;
 524              }
 525            }
 526	    if (_unsupported
 527		&& (errid == RKTIO_ERROR_UNSUPPORTED)
 528		&& (errkind == RKTIO_ERROR_KIND_RACKET))
 529	      *_unsupported = 1;
 530          }
 531          break;
 532	case 'e':
 533        case 'm':
 534	case 'E':
 535        case 'M':
 536	case 'Z':
 537	case 'N':
 538	  {
 539	    int en, he, none = 0;
 540	    char *es;
 541            const char *errkind_str = NULL;
 542            Scheme_Object *err_kind = NULL;
 543            
 544	    if (type == 'm') {
 545              none = !ints[ip++];
 546	      type = 'e';
 547              he = 0;
 548	    } else if (type == 'M') {
 549              none = !ints[ip++];
 550	      type = 'E';
 551              he = 0;
 552	    } else if (type == 'N') {
 553	      he = ints[ip++];
 554	      type = 'E';
 555	    } else
 556	      he = 0;
 557
 558	    en = ints[ip++];
 559
 560	    if (type == 'Z')
 561	      es = ptrs[pp++];
 562	    else
 563	      es = NULL;
 564
 565	    if (he) {
 566	      es = (char *)scheme_hostname_error(en);
 567              err_kind = gai_symbol;
 568              errkind_str = "gai_err";
 569            }
 570
 571	    if ((en || es) && !none) {
 572#ifdef NO_STRERROR_AVAILABLE
 573	      if (!es)
 574		es = "Unknown error";
 575              err_kind = posix_symbol;
 576#else
 577# ifdef DOS_FILE_SYSTEM
 578	      wchar_t mbuf[256];
 579              int len;
 580	      if ((type != 'e') && !es) {
 581		if ((len = FormatMessageW((FORMAT_MESSAGE_FROM_SYSTEM
 582                                           | FORMAT_MESSAGE_IGNORE_INSERTS), 
 583                                          NULL,
 584                                          en, MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
 585                                          mbuf, 255, NULL))) {
 586		  int i;
 587                  i = scheme_utf8_encode((const unsigned int *)mbuf, 0, len, NULL, 0, 1);
 588                  es = (char *)scheme_malloc_atomic(i + 1);
 589                  (void)scheme_utf8_encode((const unsigned int *)mbuf, 0, len, es, 0, 1);
 590                  es[i] = 0;
 591		  /* Remove newlines: */
 592		  for (i = strlen(es) - 1; i > 0; i--) {
 593		    if (isspace(es[i]))
 594		      es[i] = 0;
 595		    else
 596		      break;
 597		  }
 598                  err_kind = windows_symbol;
 599                  errkind_str = "win_err";
 600		}
 601	      }
 602# endif
 603	      if (!es) {
 604		es = strerror(en);
 605                err_kind = posix_symbol;
 606                errkind_str = "errno";
 607              }
 608#endif
 609	      tlen = strlen(es) + 24;
 610	      t = (const char *)scheme_malloc_atomic(tlen);
 611
 612              MZ_ASSERT(errkind_str);
 613	      sprintf((char *)t, "%s; %s=%d", es, errkind_str, en);
 614	      tlen = strlen(t);
 615              if (_errno_val) {
 616                err_kind = scheme_make_pair(scheme_make_integer_value(en), err_kind);
 617                *_errno_val = err_kind;
 618              }
 619	    } else {
 620              if (none) {
 621                t = "";
 622                tlen = 0;
 623              } else {
 624                t = "errno=?";
 625                tlen = 7;
 626              }
 627	    }
 628
 629	  }
 630	  break;
 631	case 'S':
 632	  {
 633	    Scheme_Object *sym;
 634	    sym = (Scheme_Object *)ptrs[pp++];
 635	    t = scheme_symbol_name_and_size(sym, (uintptr_t *)&tlen, 0);
 636	  }
 637	  break;
 638	case 'V':
 639	  {
 640	    Scheme_Object *o;
 641	    o = (Scheme_Object *)ptrs[pp++];
 642	    t = scheme_make_provided_string(o, 1, &tlen);
 643	  }
 644	  break;
 645	case '@':
 646	  {
 647	    Scheme_Object *o;
 648	    o = (Scheme_Object *)ptrs[pp++];
 649	    t = make_provided_list(o, 1, &tlen);
 650	  }
 651	  break;
 652	case 'D':
 653	  {
 654	    Scheme_Object *o;
 655            intptr_t dlen;
 656	    o = (Scheme_Object *)ptrs[pp++];
 657	    t = scheme_display_to_string(o, &dlen);
 658            tlen = dlen;
 659	  }
 660	  break;
 661	case 'W':
 662	  {
 663	    Scheme_Object *o;
 664            intptr_t dlen;
 665	    o = (Scheme_Object *)ptrs[pp++];
 666	    t = scheme_write_to_string(o, &dlen);
 667            tlen = dlen;
 668	  }
 669	  break;
 670        case '_':
 671          {
 672            pp++;
 673            t = "";
 674            tlen = 0;
 675          }
 676          break;
 677	case 'T':
 678	case 'Q':
 679	  {
 680	    Scheme_Object *str;
 681	    str = (Scheme_Object *)ptrs[pp++];
 682	    if (SCHEME_CHAR_STRINGP(str))
 683	      str = scheme_char_string_to_byte_string(str);
 684	    t = SCHEME_BYTE_STR_VAL(str);
 685	    tlen = SCHEME_BYTE_STRLEN_VAL(str);
 686	  }
 687	  break;
 688	case 'u':
 689	case '5':
 690	  {
 691	    mzchar *u;
 692	    intptr_t ltlen;
 693	    u = (mzchar *)ptrs[pp++];
 694	    if (type == 'u') {
 695	      tlen = ints[ip++];
 696	      if (tlen < 0)
 697		tlen = scheme_char_strlen(u);
 698	    } else {
 699	      tlen = scheme_char_strlen(u);
 700	    }
 701	    t = scheme_utf8_encode_to_buffer_len(u, tlen, NULL, 0, &ltlen);
 702	    tlen = ltlen;
 703	  }
 704	  break;
 705	default:
 706	  {
 707	    t = (char *)ptrs[pp++];
 708	    if (type == 't') {
 709	      tlen = ints[ip++];
 710	      if (tlen < 0)
 711		tlen = strlen(t);
 712	    } else {
 713	      tlen = strlen(t);
 714	    }
 715	  }
 716	  break;
 717	}
 718
 719	if ((type == 'q') || (type == 'Q')) {
 720	  if (tlen > 256) {
 721	    tlen = 250;
 722	    dots = 1;
 723	  }
 724	}
 725
 726
 727	while (tlen && i < maxlen) {
 728	  s[i++] = *t;
 729	  t = t XFORM_OK_PLUS 1;
 730	  tlen--;
 731	}
 732
 733	if (dots) {
 734	  /* FIXME: avoiding truncating in the middle of a UTF-8 encoding */
 735	  if (i < maxlen - 3) {
 736	    s[i++] = '.';
 737	    s[i++] = '.';
 738	    s[i++] = '.';
 739	  }
 740	}
 741      }
 742    } else {
 743      s[i++] = msg[j++];
 744    }
 745  }
 746
 747  s[i] = 0;
 748
 749  return i;
 750}
 751
 752intptr_t scheme_sprintf(char *s, intptr_t maxlen, const char *msg, ...)
 753{
 754  intptr_t len;
 755  GC_CAN_IGNORE va_list args;
 756
 757  HIDE_FROM_XFORM(va_start(args, msg));
 758  len = sch_vsprintf(s, maxlen, msg, args, NULL, NULL, NULL);
 759  HIDE_FROM_XFORM(va_end(args));
 760
 761  return len;
 762}
 763
 764int scheme_last_error_is_racket(int errid)
 765{
 766  return ((rktio_get_last_error_kind(scheme_rktio) == RKTIO_ERROR_KIND_RACKET)
 767          && (rktio_get_last_error(scheme_rktio) == errid));
 768}
 769
 770#define ESCAPING_NONCM_PRIM(name, func, a1, a2, env) \
 771  p = scheme_make_noncm_prim(func, name, a1, a2); \
 772  SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_ALWAYS_ESCAPES); \
 773  scheme_addto_prim_instance(name, p, env);
 774
 775void scheme_init_error(Scheme_Startup_Env *env)
 776{
 777  Scheme_Object *p;
 778
 779  if (!scheme_console_printf)
 780    scheme_console_printf = default_printf;
 781  if (!scheme_console_output)
 782    scheme_console_output = default_output;
 783
 784  REGISTER_SO(scheme_raise_arity_error_proc);
 785
 786  /* errors */
 787  ESCAPING_NONCM_PRIM("error",                      error,                 1, -1, env);
 788  ESCAPING_NONCM_PRIM("raise-user-error",           raise_user_error,      1, -1, env);
 789  ESCAPING_NONCM_PRIM("raise-type-error",           raise_type_error,      3, -1, env);
 790  ESCAPING_NONCM_PRIM("raise-argument-error",       raise_argument_error,  3, -1, env);
 791  ESCAPING_NONCM_PRIM("raise-result-error",         raise_result_error,    3, -1, env);
 792  ESCAPING_NONCM_PRIM("raise-arguments-error",      raise_arguments_error, 2, -1, env);
 793  ESCAPING_NONCM_PRIM("raise-mismatch-error",       raise_mismatch_error,  3, -1, env);
 794  ESCAPING_NONCM_PRIM("raise-range-error",          raise_range_error,     7, 8, env);
 795
 796  scheme_raise_arity_error_proc =                  scheme_make_noncm_prim(raise_arity_error, "raise-arity-error", 2, -1);
 797  scheme_addto_prim_instance("raise-arity-error",  scheme_raise_arity_error_proc, env);
 798  ESCAPING_NONCM_PRIM("raise-arity-mask-error",     raise_arity_mask_error, 2, -1, env);
 799  ESCAPING_NONCM_PRIM("raise-result-arity-error",   raise_result_arity_error, 3, -1, env);
 800
 801  ADD_PARAMETER("error-display-handler",       error_display_handler,      MZCONFIG_ERROR_DISPLAY_HANDLER,       env);
 802  ADD_PARAMETER("error-value->string-handler", error_value_string_handler, MZCONFIG_ERROR_PRINT_VALUE_HANDLER,   env);
 803  ADD_PARAMETER("error-escape-handler",        error_escape_handler,       MZCONFIG_ERROR_ESCAPE_HANDLER,        env);
 804  ADD_PARAMETER("exit-handler",                exit_handler,               MZCONFIG_EXIT_HANDLER,                env);
 805  ADD_PARAMETER("executable-yield-handler",    exe_yield_handler,          MZCONFIG_EXE_YIELD_HANDLER,           env);
 806  ADD_PARAMETER("error-print-width",           error_print_width,          MZCONFIG_ERROR_PRINT_WIDTH,           env);
 807  ADD_PARAMETER("error-print-context-length",  error_print_context_length, MZCONFIG_ERROR_PRINT_CONTEXT_LENGTH,  env);
 808  ADD_PARAMETER("error-print-source-location", error_print_srcloc,         MZCONFIG_ERROR_PRINT_SRCLOC,          env);
 809
 810  ADD_NONCM_PRIM("exit",              scheme_do_exit,  0, 1, env);
 811
 812  /* logging */
 813  ADD_NONCM_PRIM("log-level?",        log_level_p,     2, 3, env);
 814  ADD_NONCM_PRIM("log-max-level",     log_max_level,   1, 2, env);
 815  ADD_NONCM_PRIM("log-all-levels",    log_all_levels,  1, 1, env);
 816  ADD_NONCM_PRIM("log-level-evt",     log_level_evt,   1, 1, env);
 817  ADD_NONCM_PRIM("make-logger",       make_logger,     0, -1, env);
 818  ADD_NONCM_PRIM("make-log-receiver", make_log_reader, 2, -1, env);
 819
 820  ADD_PRIM_W_ARITY("log-message",    log_message,   3, 6, env);
 821  ADD_FOLDING_PRIM("logger?",        logger_p,      1, 1, 1, env);
 822  ADD_FOLDING_PRIM("logger-name",    logger_name,   1, 1, 1, env);
 823  ADD_FOLDING_PRIM("log-receiver?",  log_reader_p,  1, 1, 1, env);
 824
 825  ADD_PARAMETER("current-logger",    current_logger, MZCONFIG_LOGGER, env);
 826
 827  ADD_NONCM_PRIM("srcloc->string",   srcloc_to_string, 1, 1, env);
 828
 829  ADD_NONCM_PRIM("unquoted-printing-string",   unquoted_printing_string, 1, 1, env);
 830  ADD_FOLDING_PRIM("unquoted-printing-string?",  unquoted_printing_string_p, 1, 1, 1, env);
 831  ADD_IMMED_PRIM("unquoted-printing-string-value",  unquoted_printing_string_value, 1, 1, env);
 832
 833  REGISTER_SO(scheme_def_exit_proc);
 834  REGISTER_SO(default_display_handler);
 835  REGISTER_SO(emergency_display_handler);
 836
 837  scheme_def_exit_proc = scheme_make_prim_w_arity(def_exit_handler_proc, "default-exit-handler", 1, 1);
 838  default_display_handler = scheme_make_prim_w_arity(def_error_display_proc, "default-error-display-handler", 2, 2);
 839  emergency_display_handler = scheme_make_prim_w_arity(emergency_error_display_proc, "emergency-error-display-handler", 2, 2);
 840  
 841
 842  REGISTER_SO(def_err_val_proc);
 843  def_err_val_proc = scheme_make_prim_w_arity(def_error_value_string_proc, "default-error-value->string-handler", 2, 2);
 844
 845  REGISTER_SO(none_symbol);
 846  REGISTER_SO(fatal_symbol);
 847  REGISTER_SO(error_symbol);
 848  REGISTER_SO(warning_symbol);
 849  REGISTER_SO(info_symbol);
 850  REGISTER_SO(debug_symbol);
 851  none_symbol    = scheme_intern_symbol("none");
 852  fatal_symbol    = scheme_intern_symbol("fatal");
 853  error_symbol    = scheme_intern_symbol("error");
 854  warning_symbol  = scheme_intern_symbol("warning");
 855  info_symbol     = scheme_intern_symbol("info");
 856  debug_symbol    = scheme_intern_symbol("debug");
 857
 858  REGISTER_SO(posix_symbol);
 859  REGISTER_SO(windows_symbol);
 860  REGISTER_SO(gai_symbol);
 861  posix_symbol    = scheme_intern_symbol("posix");
 862  windows_symbol  = scheme_intern_symbol("windows");
 863  gai_symbol      = scheme_intern_symbol("gai");
 864
 865  REGISTER_SO(arity_property);
 866  {
 867    Scheme_Object *guard;
 868    guard = scheme_make_prim_w_arity(check_arity_property_value_ok, "guard-for-prop:arity-string", 2, 2);
 869    arity_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("arity-string"), guard);
 870  }
 871                                                            
 872  scheme_addto_prim_instance("prop:arity-string", arity_property, env);
 873
 874  REGISTER_SO(def_exe_yield_proc);
 875  def_exe_yield_proc = scheme_make_prim_w_arity(default_yield_handler,
 876                                                "default-executable-yield-handler",
 877                                                1, 1);
 878}
 879
 880void scheme_init_logger_wait()
 881{
 882  scheme_add_evt(scheme_log_reader_type, (Scheme_Ready_Fun)log_reader_get, NULL, NULL, 1);
 883}
 884
 885void scheme_init_logger()
 886{
 887  REGISTER_SO(scheme_main_logger);
 888  scheme_main_logger = scheme_make_logger(NULL, NULL);
 889  scheme_main_logger->syslog_level = init_syslog_level;
 890  scheme_main_logger->stderr_level = init_stderr_level;
 891  scheme_main_logger->stdout_level = init_stdout_level;
 892
 893  REGISTER_SO(scheme_gc_logger);
 894  scheme_gc_logger = scheme_make_logger(scheme_main_logger, scheme_intern_symbol("GC"));
 895
 896  REGISTER_SO(scheme_future_logger);
 897  scheme_future_logger = scheme_make_logger(scheme_main_logger, scheme_intern_symbol("future"));
 898
 899  REGISTER_SO(scheme_place_logger);
 900  scheme_place_logger = scheme_make_logger(scheme_main_logger, scheme_intern_symbol("place"));
 901}
 902
 903Scheme_Logger *scheme_get_main_logger() {
 904  return scheme_main_logger;
 905}
 906
 907Scheme_Logger *scheme_get_gc_logger() {
 908  return scheme_gc_logger;
 909}
 910
 911Scheme_Logger *scheme_get_future_logger() {
 912  return scheme_future_logger;
 913}
 914
 915Scheme_Logger *scheme_get_place_logger() {
 916  return scheme_place_logger;
 917}
 918
 919void scheme_init_error_config(void)
 920{
 921  scheme_set_root_param(MZCONFIG_EXIT_HANDLER, scheme_def_exit_proc);
 922  scheme_set_root_param(MZCONFIG_ERROR_DISPLAY_HANDLER, default_display_handler);
 923  scheme_set_root_param(MZCONFIG_ERROR_PRINT_VALUE_HANDLER, def_err_val_proc);
 924  scheme_set_root_param(MZCONFIG_EXE_YIELD_HANDLER, def_exe_yield_proc);
 925}
 926
 927void scheme_init_logger_config() {
 928  scheme_set_root_param(MZCONFIG_LOGGER, (Scheme_Object *)scheme_main_logger);
 929}
 930
 931static MZ_NORETURN void
 932call_error(char *buffer, int len, Scheme_Object *exn)
 933{
 934  if (scheme_current_thread->constant_folding) {
 935    if (scheme_current_thread->constant_folding != (Optimize_Info *)scheme_false)
 936      scheme_log(scheme_optimize_info_logger(scheme_current_thread->constant_folding),
 937                 SCHEME_LOG_WARNING,
 938                 0,
 939                 "constant-fold attempt failed%s: %s",
 940                 scheme_optimize_info_context(scheme_current_thread->constant_folding),
 941                 buffer);
 942    if (SCHEME_CHAPERONE_STRUCTP(exn)
 943        && scheme_is_struct_instance(exn_table[MZEXN_BREAK].type, exn)) {
 944      /* remember to re-raise exception */
 945      scheme_current_thread->reading_delayed = exn;
 946    }
 947    scheme_longjmp(scheme_error_buf, 1);
 948  } else if (scheme_current_thread->reading_delayed) {
 949    scheme_current_thread->reading_delayed = exn;
 950    scheme_longjmp(scheme_error_buf, 1);
 951  } else {
 952    mz_jmp_buf savebuf;
 953    Scheme_Object *p[2], *display_handler, *escape_handler, *v;
 954    Scheme_Config *config, *orig_config;
 955    Scheme_Cont_Frame_Data cframe, cframe2;
 956
 957    /* For last resort: */
 958    memcpy((void *)&savebuf, &scheme_error_buf, sizeof(mz_jmp_buf));
 959
 960    orig_config = scheme_current_config();
 961    display_handler = scheme_get_param(orig_config, MZCONFIG_ERROR_DISPLAY_HANDLER);
 962    escape_handler = scheme_get_param(orig_config, MZCONFIG_ERROR_ESCAPE_HANDLER);
 963    
 964    v = scheme_make_byte_string_without_copying("error display handler");
 965    v = scheme_make_closed_prim_w_arity((Scheme_Closed_Prim *)nested_exn_handler,
 966					scheme_make_pair(v, exn),
 967					"nested-exception-handler", 
 968					1, 1);
 969
 970    config = orig_config;
 971    if (SAME_OBJ(display_handler, default_display_handler))
 972      config = scheme_extend_config(config,
 973				    MZCONFIG_ERROR_DISPLAY_HANDLER,
 974				    emergency_display_handler);
 975    else
 976      config = scheme_extend_config(config,
 977				    MZCONFIG_ERROR_DISPLAY_HANDLER,
 978				    default_display_handler);
 979    
 980    scheme_push_continuation_frame(&cframe);
 981    scheme_install_config(config);
 982    scheme_set_cont_mark(scheme_exn_handler_key, v);
 983    scheme_push_break_enable(&cframe2, 0, 0);
 984
 985    if (SCHEME_CHAPERONE_STRUCTP(exn)
 986        && (scheme_is_struct_instance(exn_table[MZEXN_BREAK_HANG_UP].type, exn))) {
 987      /* skip printout */
 988    } else {
 989      p[0] = scheme_make_immutable_sized_utf8_string(buffer, len);
 990      p[1] = exn;
 991      scheme_apply_multi(display_handler, 2, p);
 992    }
 993
 994    if (SCHEME_CHAPERONE_STRUCTP(exn)
 995        && (scheme_is_struct_instance(exn_table[MZEXN_BREAK_HANG_UP].type, exn)
 996            || scheme_is_struct_instance(exn_table[MZEXN_BREAK_TERMINATE].type, exn))) {
 997      /* Default uncaught exception handler exits on `exn:break:hang-up'
 998         or `exn:break:terminate'. */
 999      p[0] = scheme_make_integer(1);
1000      scheme_do_exit(1, p);
1001      /* Fall through to regular escape if the exit handler doesn't exit/escape. */
1002    }
1003
1004    v = scheme_make_byte_string_without_copying("error escape handler");
1005    v = scheme_make_closed_prim_w_arity((Scheme_Closed_Prim *)nested_exn_handler,
1006					scheme_make_pair(v, exn),
1007					"nested-exception-handler", 
1008					1, 1);
1009    
1010    config = scheme_extend_config(config,
1011				  MZCONFIG_ERROR_DISPLAY_HANDLER,
1012				  default_display_handler);
1013    config = scheme_extend_config(config,
1014				  MZCONFIG_ERROR_ESCAPE_HANDLER,
1015				  def_error_esc_proc);
1016        
1017    scheme_pop_break_enable(&cframe2, 0);
1018    scheme_pop_continuation_frame(&cframe);
1019
1020    scheme_push_continuation_frame(&cframe);
1021    scheme_set_cont_mark(scheme_exn_handler_key, v);
1022    scheme_install_config(config);
1023    scheme_push_break_enable(&cframe2, 0, 0);
1024
1025    /* Typically jumps out of here */
1026    scheme_apply_multi(escape_handler, 0, NULL);
1027
1028    scheme_pop_break_enable(&cframe2, 0);
1029    scheme_pop_continuation_frame(&cframe);
1030
1031    /* Didn't escape, so fall back to the default escaper: */
1032    def_error_escape_proc(0, NULL);
1033  }
1034}
1035
1036intptr_t scheme_get_print_width(void)
1037{
1038  intptr_t print_width;
1039  Scheme_Object *w;
1040
1041  w = scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PRINT_WIDTH);
1042  if (SCHEME_INTP(w))
1043    print_width = SCHEME_INT_VAL(w);
1044  else if (SCHEME_BIGNUMP(w))
1045    print_width = 0x7FFFFFFF;
1046  else
1047    print_width = 10000;
1048
1049  return print_width;
1050}
1051
1052static char *init_buf(intptr_t *len, intptr_t *_size)
1053{
1054  uintptr_t local_max_symbol_length;
1055  intptr_t print_width;
1056  intptr_t size;
1057  
1058  local_max_symbol_length = scheme_get_max_symbol_length();
1059  print_width             = scheme_get_print_width();
1060
1061  size = (3 * local_max_symbol_length + 500 + 2 * print_width);
1062
1063  /* out parameters */
1064  if (len)
1065    *len = print_width;
1066  if (_size)
1067    *_size = size;
1068
1069  return (char *)scheme_malloc_atomic(size);
1070}
1071
1072void
1073scheme_signal_error (const char *msg, ...)
1074{
1075  GC_CAN_IGNORE va_list args;
1076  char *buffer;
1077  intptr_t len;
1078
1079  HIDE_FROM_XFORM(va_start(args, msg));
1080  len = sch_vsprintf(NULL, 0, msg, args, &buffer, NULL, NULL);
1081  HIDE_FROM_XFORM(va_end(args));
1082
1083  buffer[len] = 0;
1084
1085  if (scheme_starting_up) {
1086    buffer[len++] = '\n';
1087    buffer[len] = 0;
1088    scheme_console_output(buffer, len);
1089    exit(0);
1090  }
1091
1092  scheme_raise_exn(MZEXN_FAIL, "%t", buffer, len);
1093}
1094
1095void scheme_warning(char *msg, ...)
1096{
1097  GC_CAN_IGNORE va_list args;
1098  char *buffer;
1099  intptr_t len;
1100
1101  HIDE_FROM_XFORM(va_start(args, msg));
1102  len = sch_vsprintf(NULL, 0, msg, args, &buffer, NULL, NULL);
1103  HIDE_FROM_XFORM(va_end(args));
1104
1105  buffer[len++] = '\n';
1106  buffer[len] = 0;
1107
1108  scheme_write_byte_string(buffer, len,
1109			   scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PORT));
1110}
1111
1112void scheme_ensure_console_ready()
1113{
1114  rktio_create_console();
1115}
1116
1117void scheme_log(Scheme_Logger *logger, int level, int flags,
1118                const char *msg, ...)
1119{
1120  GC_CAN_IGNORE va_list args;
1121  char *buffer;
1122  intptr_t len;
1123
1124  if (logger) {
1125    if (logger->local_timestamp == SCHEME_INT_VAL(logger->root_timestamp[0]))
1126      if (logger->want_level < level)
1127        return;
1128  }
1129
1130  HIDE_FROM_XFORM(va_start(args, msg));
1131  len = sch_vsprintf(NULL, 0, msg, args, &buffer, NULL, NULL);
1132  HIDE_FROM_XFORM(va_end(args));
1133
1134  buffer[len] = 0;
1135
1136  scheme_log_message(logger, level, buffer, len, NULL);
1137}
1138
1139void scheme_log_w_data(Scheme_Logger *logger, int level, int flags,
1140                       Scheme_Object *data,
1141                       const char *msg, ...)
1142{
1143  GC_CAN_IGNORE va_list args;
1144  char *buffer;
1145  intptr_t len;
1146
1147  if (logger) {
1148    if (logger->local_timestamp == SCHEME_INT_VAL(logger->root_timestamp[0]))
1149      if (logger->want_level < level)
1150        return;
1151  }
1152
1153  HIDE_FROM_XFORM(va_start(args, msg));
1154  len = sch_vsprintf(NULL, 0, msg, args, &buffer, NULL, NULL);
1155  HIDE_FROM_XFORM(va_end(args));
1156
1157  buffer[len] = 0;
1158
1159  scheme_log_message(logger, level, buffer, len, data);
1160}
1161
1162static char *error_write_to_string_w_max(Scheme_Object *v, int len, intptr_t *lenout)
1163{
1164  Scheme_Object *o, *args[2];
1165
1166  o = scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PRINT_VALUE_HANDLER);
1167
1168  if ((SAME_OBJ(o, def_err_val_proc)
1169       && SAME_OBJ(scheme_get_param(scheme_current_config(), MZCONFIG_PORT_PRINT_HANDLER),
1170		   scheme_default_global_print_handler))) {
1171    intptr_t l;
1172    char *s;
1173    s = scheme_print_to_string_w_max(v, &l, len);
1174    if (lenout)
1175      *lenout = l;
1176    return s;
1177  } else {
1178    Scheme_Config *config;
1179    Scheme_Cont_Frame_Data cframe, cframe2;
1180
1181    args[0] = v;
1182    args[1] = scheme_make_integer(len);
1183
1184    config = scheme_extend_config(scheme_current_config(),
1185				  MZCONFIG_ERROR_PRINT_VALUE_HANDLER,
1186				  def_err_val_proc);
1187    config = scheme_extend_config(config,
1188				  MZCONFIG_PRINT_UNREADABLE,
1189				  scheme_true);
1190
1191    scheme_push_continuation_frame(&cframe);
1192    scheme_install_config(config);
1193    scheme_push_break_enable(&cframe2, 0, 0);
1194
1195    o = _scheme_apply(o, 2, args);
1196
1197    scheme_pop_break_enable(&cframe2, 0);
1198    scheme_pop_continuation_frame(&cframe);
1199
1200    if (SCHEME_CHAR_STRINGP(o)) {
1201      o = scheme_char_string_to_byte_string(o);
1202    }
1203
1204    if (SCHEME_BYTE_STRINGP(o)) {
1205      char *s = SCHEME_BYTE_STR_VAL(o);
1206      if (SCHEME_BYTE_STRTAG_VAL(o) > len) {
1207	char *naya;
1208	naya = scheme_malloc_atomic(len + 1);
1209	memcpy(naya, s, len);
1210	s[len] = 0;
1211	if (lenout)
1212	  *lenout = len;
1213      } else if (lenout)
1214	*lenout = SCHEME_BYTE_STRTAG_VAL(o);
1215      return s;
1216    } else {
1217      if (lenout)
1218	*lenout = 3;
1219      return "...";
1220    }
1221  }
1222}
1223
1224static Scheme_Object *check_arity_property_value_ok(int argc, Scheme_Object *argv[])
1225{
1226  if (!scheme_check_proc_arity(NULL, 1, 0, 1, argv))
1227    scheme_arg_mismatch("guard-for-prop:arity-string",
1228                        "property value is not a procedure (arity 1): ",
1229                        argv[0]);
1230  return argv[0];
1231}
1232
1233static char *make_arity_expect_string(const char *name, int namelen,
1234				      int minc, int maxc,
1235				      int argc, Scheme_Object **argv,
1236				      intptr_t *_len, int is_method,
1237                                      const char *map_name)
1238/* minc == -1 => name is really a case-lambda, native closure, or proc-struct.
1239   minc == -2 => use generic arity-mismatch message */
1240{
1241  intptr_t len, pos, slen;
1242  int xargc, xminc, xmaxc;
1243  char *s, *arity_str = NULL;
1244  const char *prefix_msg1, *prefix_msg2, *suffix_msg;
1245  int arity_len = 0;
1246
1247  s = init_buf(&len, &slen);
1248
1249  if (!name)
1250    name = "#<procedure>";
1251
1252  xargc = argc - (is_method ? 1 : 0);
1253  xminc = minc - (is_method ? 1 : 0);
1254  xmaxc = maxc - (is_method ? 1 : 0);
1255
1256  if ((minc == -1) && SCHEME_CHAPERONE_PROC_STRUCTP((Scheme_Object *)name)) {
1257    Scheme_Object *arity_maker;
1258
1259    while (1) {
1260      arity_maker = scheme_struct_type_property_ref(arity_property, (Scheme_Object *)name);
1261      if (arity_maker) {
1262        Scheme_Object *v, *a[1];
1263        a[0] = (Scheme_Object *)name;
1264        v = scheme_apply(arity_maker, 1, a);
1265        if (SCHEME_CHAR_STRINGP(v)) {
1266          v = scheme_char_string_to_byte_string(v);
1267          arity_str = SCHEME_BYTE_STR_VAL(v);
1268          arity_len = SCHEME_BYTE_STRLEN_VAL(v);
1269          if (arity_len > len)
1270            arity_len = len;
1271          name = scheme_get_proc_name((Scheme_Object *)name, &namelen, 1);
1272          if (!name) {
1273            name = "#<procedure>";
1274            namelen = strlen(name);
1275          }
1276          break;
1277        } else
1278          break;
1279      } else {
1280        Scheme_Object *v;
1281        int is_method;
1282        v = (Scheme_Object *)name;
1283        if (SCHEME_CHAPERONEP(v))
1284          v = SCHEME_CHAPERONE_VAL(v);
1285        if (scheme_is_struct_instance(scheme_reduced_procedure_struct, v))
1286          v = NULL; /* hide any wider type that a nested structure might report */
1287        else
1288          v = scheme_extract_struct_procedure(v, -1, NULL, &is_method);
1289        if (!v || is_method || !SCHEME_CHAPERONE_PROC_STRUCTP(v))
1290          break;
1291        name = (const char *)v;
1292      }
1293      SCHEME_USE_FUEL(1);
1294    }
1295
1296    if (!arity_str) {
1297      /* If the arity is something simple, we'll make a good error
1298         message. Otherwise, we'll just use the "no matching case"
1299         version. */
1300      Scheme_Object *arity;
1301      arity = scheme_arity((Scheme_Object *)name);
1302      if (SCHEME_INTP(arity)) {
1303        minc = maxc = SCHEME_INT_VAL(arity);
1304        xmaxc = xminc = minc - (is_method ? 1 : 0);
1305        name = scheme_get_proc_name((Scheme_Object *)name, &namelen, 1);
1306        if (!name) {
1307          name = "#<procedure>";
1308          namelen = strlen(name);
1309        }
1310      }
1311    }
1312  }
1313
1314  if (map_name) {
1315    prefix_msg1 = map_name;
1316    prefix_msg2 = (": argument mismatch;\n"
1317                   " the given procedure's expected number of arguments does not match\n"
1318                   " the given number of lists\n"
1319                   "  given procedure: ");
1320    suffix_msg = "";
1321  } else {
1322    prefix_msg1 = "";
1323    prefix_msg2 = "";
1324    suffix_msg = (": arity mismatch;\n"
1325                  " the expected number of arguments does not match the given number");
1326  }
1327
1328  if (arity_str) {
1329    pos = scheme_sprintf(s, slen, 
1330                         "%s%s%t%s\n"
1331                         "  expected: %t\n"
1332                         "  given: %d",
1333                         prefix_msg1, prefix_msg2,
1334			 name, (intptr_t)namelen, 
1335                         suffix_msg,
1336                         arity_str, (intptr_t)arity_len, xargc);
1337  } else if (minc < 0) {
1338    const char *n;
1339    int nlen;
1340
1341    if (minc == -2) {
1342      n = name;
1343      nlen = (namelen < 0 ? strlen(n) : namelen);
1344    } else
1345      n = scheme_get_proc_name((Scheme_Object *)name, &nlen, 1);
1346
1347    if (!n) {
1348      n = "#<case-lambda-procedure>";
1349      nlen = strlen(n);
1350    }
1351
1352    pos = scheme_sprintf(s, slen, 
1353                         "%s%s%t%s\n"
1354                         "  given: %d",
1355                         prefix_msg1, prefix_msg2,
1356			 n, (intptr_t)nlen,
1357                         suffix_msg,
1358			 xargc);
1359  } else if (!maxc)
1360    pos = scheme_sprintf(s, slen, 
1361                         "%s%s%t%s\n"
1362                         "  expected: 0\n"
1363                         "  given: %d",
1364                         prefix_msg1, prefix_msg2,
1365			 name, (intptr_t)namelen, 
1366                         suffix_msg,
1367                         xargc);
1368  else if (maxc < 0)
1369    pos = scheme_sprintf(s, slen, 
1370                         "%s%s%t%s\n"
1371                         "  expected: at least %d\n"
1372                         "  given: %d",
1373                         prefix_msg1, prefix_msg2,
1374			 name, (intptr_t)namelen, 
1375                         suffix_msg,
1376                         xminc, xargc);
1377  else if (minc == maxc)
1378    pos = scheme_sprintf(s, slen, 
1379                         "%s%s%t%s\n"
1380                         "  expected: %d\n"
1381                         "  given: %d",
1382                         prefix_msg1, prefix_msg2,
1383			 name, (intptr_t)namelen, 
1384                         suffix_msg,
1385                         xminc, xargc);
1386  else
1387    pos = scheme_sprintf(s, slen, 
1388                         "%s%s%t%s\n"
1389                         "  expected: %d to %d\n"
1390                         "  given: %d",
1391                         prefix_msg1, prefix_msg2,
1392			 name, (intptr_t)namelen, 
1393                         suffix_msg,
1394                         xminc, xmaxc, xargc);
1395
1396  if (xargc && argv) {
1397    len -= (xargc * 4);
1398    len /= xargc;
1399    if ((xargc < 50) && (len >= 3)) {
1400      int i;
1401
1402      for (i = (is_method ? 1 : 0); i < argc; i++) {
1403	intptr_t l;
1404	char *o;
1405        if (i == (is_method ? 1 : 0)) {
1406          strcpy(s + pos, "\n  arguments...:\n   ");
1407          pos += 20;
1408        } else {
1409          strcpy(s + pos, "\n   ");
1410          pos += 4;
1411        }
1412
1413	o = error_write_to_string_w_max(argv[i], len, &l);
1414	memcpy(s + pos, o, l);
1415	pos += l;
1416      }
1417
1418      s[pos] = 0;
1419    }
1420  }
1421
1422  *_len = pos;
1423
1424  return s;
1425}
1426
1427void scheme_wrong_count_m(const char *name, int minc, int maxc,
1428			  int argc, Scheme_Object **argv, int is_method)
1429/* minc == -1 => name is really a proc.
1430   minc == -2 => use generic "no matching clause" message */
1431{
1432  char *s;
1433  intptr_t len;
1434  Scheme_Thread *p = scheme_current_thread;
1435
1436  if (argv == p->tail_buffer) {
1437    /* See calls in scheme_do_eval: */
1438    scheme_realloc_tail_buffer(p);
1439  }
1440
1441  /* minc = 1 -> name is really a case-lambda or native proc */
1442
1443  if (minc == -1) {
1444    /* Extract arity, check for is_method in case-lambda, etc. */
1445    if (SAME_TYPE(SCHEME_TYPE((Scheme_Object *)name), scheme_closure_type)) {
1446      Scheme_Lambda *data;
1447      data = SCHEME_CLOSURE_CODE((Scheme_Object *)name);
1448      name = scheme_get_proc_name((Scheme_Object *)name, NULL, 1);
1449      
1450      minc = data->num_params;
1451      if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_REST) {
1452        minc -= 1;
1453        maxc = -1;
1454      } else
1455        maxc = minc;
1456    } else if (SAME_TYPE(SCHEME_TYPE((Scheme_Object *)name), scheme_case_closure_type)) {
1457      Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)name;
1458      if (cl->count) {
1459	Scheme_Lambda *data;
1460	data = (Scheme_Lambda *)SCHEME_CLOSURE_CODE(cl->array[0]);
1461	if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_IS_METHOD)
1462	  is_method = 1;
1463      } else if (cl->name && SCHEME_BOXP(cl->name)) {
1464	/* See note in schpriv.h about the IS_METHOD hack */
1465	is_method = 1;
1466      }
1467#ifdef MZ_USE_JIT
1468    } else if (SAME_TYPE(SCHEME_TYPE((Scheme_Object *)name), scheme_native_closure_type)) {
1469      Scheme_Object *pa;
1470      pa = scheme_get_native_arity((Scheme_Object *)name, -1);
1471      if (SCHEME_BOXP(pa)) {
1472	pa = SCHEME_BOX_VAL(pa);
1473	is_method = 1;
1474      }
1475      if (SCHEME_INTP(pa)) {
1476	minc = SCHEME_INT_VAL(pa);
1477	if (minc < 0) {
1478	  minc = (-minc) - 1;
1479	  maxc = -1;
1480	} else
1481	  maxc = minc;
1482	name = scheme_get_proc_name((Scheme_Object *)name, NULL, 1);
1483      } else if (SCHEME_STRUCTP(pa)) {
1484	/* This happens when a non-case-lambda is not yet JITted.
1485	   It's an arity-at-least record. */
1486	pa = ((Scheme_Structure *)pa)->slots[0];
1487	minc = SCHEME_INT_VAL(pa);
1488	maxc = -1;
1489	name = scheme_get_proc_name((Scheme_Object *)name, NULL, 1);
1490      } else {
1491	/* complex; use "no matching case" msg */
1492      }
1493#endif
1494    }
1495  }
1496
1497  /* Watch out for impossible is_method claims: */
1498  if (!argc || !minc)
1499    is_method = 0;
1500
1501  if (maxc > SCHEME_MAX_ARGS)
1502    maxc = -1;
1503
1504  s = make_arity_expect_string(name, -1, minc, maxc, argc, argv, &len, is_method, NULL);
1505
1506  scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY, "%t", s, len);
1507}
1508
1509void scheme_wrong_count(const char *name, int minc, int maxc, int argc,
1510			Scheme_Object **argv)
1511{
1512  /* don't allocate here, in case rands == p->tail_buffer */
1513  scheme_wrong_count_m(name, minc, maxc, argc, argv, 0);
1514}
1515
1516void scheme_case_lambda_wrong_count(const char *name,
1517				    int argc, Scheme_Object **argv,
1518				    int is_method,
1519				    int count, ...)
1520{
1521  char *s;
1522  intptr_t len;
1523
1524  /* Watch out for impossible is_method claims: */
1525  if (!argc)
1526    is_method = 0;
1527
1528  s = make_arity_expect_string(name, -1, -2, 0, argc, argv, &len, is_method, NULL);
1529
1530  scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY, "%t", s, len);
1531}
1532
1533char *scheme_make_arity_expect_string(const char *map_name,
1534                                      Scheme_Object *proc,
1535				      int argc, Scheme_Object **argv,
1536				      intptr_t *_slen)
1537{
1538  const char *name;
1539  int namelen = -1;
1540  int mina, maxa;
1541
1542  if (SCHEME_CHAPERONEP(proc)) {
1543    proc = SCHEME_CHAPERONE_VAL(proc);
1544  }
1545
1546  if (SCHEME_PRIMP(proc)) {
1547    name = ((Scheme_Primitive_Proc *)proc)->name;
1548    mina = ((Scheme_Primitive_Proc *)proc)->mina;
1549    if (mina < 0) {
1550      /* set min1 to -2 to indicates cases */
1551      mina = -2;
1552      maxa = 0;
1553    } else {
1554      maxa = ((Scheme_Primitive_Proc *)proc)->mu.maxa;
1555      if (maxa > SCHEME_MAX_ARGS)
1556	maxa = -1;
1557    }
1558  } else if (SCHEME_CLSD_PRIMP(proc)) {
1559    name = ((Scheme_Closed_Primitive_Proc *)proc)->name;
1560    mina = ((Scheme_Closed_Primitive_Proc *)proc)->mina;
1561    maxa = ((Scheme_Closed_Primitive_Proc *)proc)->maxa;
1562  } else if (SAME_TYPE(SCHEME_TYPE(proc), scheme_case_closure_type)) {
1563    name = scheme_get_proc_name(proc, &namelen, 1);
1564    mina = -2;
1565    maxa = 0;
1566#ifdef MZ_USE_JIT
1567  } else if (SAME_TYPE(SCHEME_TYPE((Scheme_Object *)proc), scheme_native_closure_type)) {
1568    Scheme_Object *pa;
1569    pa = scheme_get_native_arity((Scheme_Object *)proc, -1);
1570    if (SCHEME_BOXP(pa)) {
1571      pa = SCHEME_BOX_VAL(pa);
1572    }
1573    if (SCHEME_INTP(pa)) {
1574      mina = SCHEME_INT_VAL(pa);
1575      if (mina < 0) {
1576	mina = (-mina) - 1;
1577	maxa = -1;
1578      } else
1579	maxa = mina;
1580    } else if (SCHEME_STRUCTP(pa)) {
1581      /* This happens when a non-case-lambda is not yet JITted.
1582	 It's an arity-at-least record. */
1583      pa = ((Scheme_Structure *)pa)->slots[0];
1584      mina = SCHEME_INT_VAL(pa);
1585      maxa = -1;
1586    } else {
1587      /* complex; use "no matching case" msg */
1588      mina = -2;
1589      maxa = 0;
1590    }
1591    name = scheme_get_proc_name((Scheme_Object *)proc, &namelen, 1);
1592#endif
1593  } else if (SCHEME_CHAPERONE_STRUCTP(proc)) {
1594    name = (const char *)proc;
1595    mina = -1;
1596    maxa = 0;
1597  } else {
1598    Scheme_Lambda *data;
1599
1600    data = (Scheme_Lambda *)SCHEME_CLOSURE_CODE(proc);
1601    mina = maxa = data->num_params;
1602    if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_REST) {
1603      --mina;
1604      maxa = -1;
1605    }
1606    name = scheme_get_proc_name(proc, &namelen, 1);
1607  }
1608
1609  return make_arity_expect_string(name, namelen, mina, maxa, argc, argv, _slen, 0, map_name);
1610}
1611
1612char *scheme_make_args_string(const char *s, int which, int argc, Scheme_Object **argv, intptr_t *_olen)
1613{
1614  char *other;
1615  intptr_t len;
1616  GC_CAN_IGNORE char *isres = "arguments";
1617
1618  other = init_buf(&len, NULL);
1619
1620  if (argc < 0) {
1621    isres = "results";
1622    argc = -argc;
1623  }
1624
1625  len /= (argc - (((which >= 0) && (argc > 1)) ? 1 : 0));
1626  if ((argc < 50) && (len >= 3)) {
1627    int i, pos;
1628
1629    sprintf(other, "; %s%s were:", s, isres);
1630    pos = strlen(other);
1631    for (i = 0; i < argc; i++) {
1632      if (i != which) {
1633	intptr_t l;
1634	char *o;
1635	o = error_write_to_string_w_max(argv[i], len, &l);
1636	memcpy(other + pos, " ", 1);
1637	memcpy(other + pos + 1, o, l);
1638	pos += l + 1;
1639      }
1640    }
1641    other[pos] = 0;
1642    if (_olen)
1643      *_olen = pos;
1644  } else {
1645    sprintf(other, "; given %d arguments total", argc);
1646    if (_olen)
1647      *_olen = strlen(other);
1648  }
1649
1650  return other;
1651}
1652
1653char *scheme_make_arg_lines_string(const char *indent, int which, int argc, Scheme_Object **argv, intptr_t *_olen)
1654{
1655  char *other;
1656  intptr_t len, plen;
1657
1658  if (!argc || ((argc == 1) && (which == 0))) {
1659    other = " [none]";
1660    if (_olen)
1661      *_olen = strlen(other);    
1662    return other;
1663  }
1664
1665  other = init_buf(&len, NULL);
1666
1667  plen = strlen(indent);
1668  
1669  len -= ((argc - 1) * (plen + 1));
1670  len /= (argc - (((which >= 0) && (argc > 1)) ? 1 : 0));
1671
1672  if (len >= 3) {
1673    int i, pos;
1674
1675    pos = 0;
1676    for (i = 0; i < argc; i++) {
1677      if (i != which) {
1678	intptr_t l;
1679	char *o;
1680      
1681        memcpy(other + pos, "\n", 1);
1682        pos++;
1683        memcpy(other + pos, indent, plen);
1684        pos += plen;
1685      
1686	o = error_write_to_string_w_max(argv[i], len, &l);
1687	memcpy(ot

Large files files are truncated, but you can click here to view the full file