/racket/src/racket/src/error.c
C | 4799 lines | 3963 code | 691 blank | 145 comment | 755 complexity | 6e62fdbbfda041ed054b7145fcf94e8b MD5 | raw file
Possible License(s): LGPL-3.0, GPL-3.0, BSD-3-Clause, CC-BY-SA-3.0
Large files files are truncated, but you can click here to view the full file
- #include "schpriv.h"
- #include "schrktio.h"
- #include <ctype.h>
- #ifdef DOS_FILE_SYSTEM
- # include <windows.h>
- #endif
- #ifdef NO_ERRNO_GLOBAL
- # define errno -1
- #else
- # include <errno.h>
- #endif
- #define mzVA_ARG(x, y) HIDE_FROM_XFORM(va_arg(x, y))
- #define TMP_CMARK_VALUE scheme_parameterization_key
- #ifndef INIT_SYSLOG_LEVEL
- # define INIT_SYSLOG_LEVEL 0
- #endif
- /* globals */
- SHARED_OK scheme_console_printf_t scheme_console_printf;
- scheme_console_printf_t scheme_get_console_printf() { return scheme_console_printf; }
- void scheme_set_console_printf(scheme_console_printf_t p) { scheme_console_printf = p; }
- SHARED_OK Scheme_Exit_Proc scheme_exit;
- void scheme_set_exit(Scheme_Exit_Proc p) { scheme_exit = p; }
- HOOK_SHARED_OK void (*scheme_console_output)(char *str, intptr_t len);
- void scheme_set_console_output(scheme_console_output_t p) { scheme_console_output = p; }
- SHARED_OK static Scheme_Object *init_syslog_level = scheme_make_integer(INIT_SYSLOG_LEVEL);
- SHARED_OK static Scheme_Object *init_stderr_level = scheme_make_integer(SCHEME_LOG_ERROR);
- SHARED_OK static Scheme_Object *init_stdout_level = scheme_make_integer(0);
- THREAD_LOCAL_DECL(static Scheme_Logger *scheme_main_logger);
- THREAD_LOCAL_DECL(static Scheme_Logger *scheme_gc_logger);
- THREAD_LOCAL_DECL(static Scheme_Logger *scheme_future_logger);
- THREAD_LOCAL_DECL(static Scheme_Logger *scheme_place_logger);
- /* readonly globals */
- ROSYM static Scheme_Object *none_symbol;
- ROSYM static Scheme_Object *fatal_symbol;
- ROSYM static Scheme_Object *error_symbol;
- ROSYM static Scheme_Object *warning_symbol;
- ROSYM static Scheme_Object *info_symbol;
- ROSYM static Scheme_Object *debug_symbol;
- ROSYM static Scheme_Object *posix_symbol;
- ROSYM static Scheme_Object *windows_symbol;
- ROSYM static Scheme_Object *gai_symbol;
- ROSYM static Scheme_Object *arity_property;
- ROSYM static Scheme_Object *def_err_val_proc;
- ROSYM static Scheme_Object *def_error_esc_proc;
- ROSYM static Scheme_Object *default_display_handler;
- ROSYM static Scheme_Object *emergency_display_handler;
- ROSYM static Scheme_Object *def_exe_yield_proc;
- READ_ONLY Scheme_Object *scheme_def_exit_proc;
- READ_ONLY Scheme_Object *scheme_raise_arity_error_proc;
- #ifdef MEMORY_COUNTING_ON
- intptr_t scheme_misc_count;
- #endif
- #ifdef MZ_USE_MZRT
- static mzrt_mutex *glib_log_queue_lock;
- typedef struct glib_log_queue_entry {
- const char *log_domain;
- int log_level;
- const char *message;
- struct glib_log_queue_entry *next;
- } glib_log_queue_entry;
- static glib_log_queue_entry *glib_log_queue;
- static void *glib_log_signal_handle;
- #endif
- /* locals */
- static Scheme_Object *error(int argc, Scheme_Object *argv[]);
- static Scheme_Object *raise_user_error(int argc, Scheme_Object *argv[]);
- static Scheme_Object *raise_type_error(int argc, Scheme_Object *argv[]);
- static Scheme_Object *raise_argument_error(int argc, Scheme_Object *argv[]);
- static Scheme_Object *raise_result_error(int argc, Scheme_Object *argv[]);
- static Scheme_Object *raise_mismatch_error(int argc, Scheme_Object *argv[]);
- static Scheme_Object *raise_arguments_error(int argc, Scheme_Object *argv[]);
- static Scheme_Object *raise_range_error(int argc, Scheme_Object *argv[]);
- static Scheme_Object *raise_arity_error(int argc, Scheme_Object *argv[]);
- static Scheme_Object *raise_arity_mask_error(int argc, Scheme_Object *argv[]);
- static Scheme_Object *raise_result_arity_error(int argc, Scheme_Object *argv[]);
- static Scheme_Object *error_escape_handler(int, Scheme_Object *[]);
- static Scheme_Object *error_display_handler(int, Scheme_Object *[]);
- static Scheme_Object *error_value_string_handler(int, Scheme_Object *[]);
- static Scheme_Object *exit_handler(int, Scheme_Object *[]);
- static Scheme_Object *exe_yield_handler(int, Scheme_Object *[]);
- static Scheme_Object *error_print_width(int, Scheme_Object *[]);
- static Scheme_Object *error_print_context_length(int, Scheme_Object *[]);
- static Scheme_Object *error_print_srcloc(int, Scheme_Object *[]);
- static MZ_NORETURN void def_error_escape_proc(int, Scheme_Object *[]);
- static Scheme_Object *def_error_display_proc(int, Scheme_Object *[]);
- static Scheme_Object *emergency_error_display_proc(int, Scheme_Object *[]);
- static Scheme_Object *def_error_value_string_proc(int, Scheme_Object *[]);
- static Scheme_Object *def_exit_handler_proc(int, Scheme_Object *[]);
- static Scheme_Object *default_yield_handler(int, Scheme_Object *[]);
- static Scheme_Object *srcloc_to_string(int argc, Scheme_Object **argv);
- static Scheme_Object *unquoted_printing_string(int argc, Scheme_Object **argv);
- static Scheme_Object *unquoted_printing_string_p(int argc, Scheme_Object **argv);
- static Scheme_Object *unquoted_printing_string_value(int argc, Scheme_Object **argv);
- static Scheme_Object *log_message(int argc, Scheme_Object *argv[]);
- static Scheme_Object *log_level_p(int argc, Scheme_Object *argv[]);
- static Scheme_Object *log_max_level(int argc, Scheme_Object *argv[]);
- static Scheme_Object *log_all_levels(int argc, Scheme_Object *argv[]);
- static Scheme_Object *log_level_evt(int argc, Scheme_Object *argv[]);
- static Scheme_Object *make_logger(int argc, Scheme_Object *argv[]);
- static Scheme_Object *logger_p(int argc, Scheme_Object *argv[]);
- static Scheme_Object *current_logger(int argc, Scheme_Object *argv[]);
- static Scheme_Object *logger_name(int argc, Scheme_Object *argv[]);
- static Scheme_Object *make_log_reader(int argc, Scheme_Object *argv[]);
- static Scheme_Object *log_reader_p(int argc, Scheme_Object *argv[]);
- static int log_reader_get(Scheme_Object *ch, Scheme_Schedule_Info *sinfo);
- static MZ_NORETURN void do_raise(Scheme_Object *arg, int need_debug, int barrier);
- static MZ_NORETURN void nested_exn_handler(void *old_exn, int argc, Scheme_Object *argv[]);
- static void update_want_level(Scheme_Logger *logger, Scheme_Object *name);
- static Scheme_Object *check_arity_property_value_ok(int argc, Scheme_Object *argv[]);
- static char *make_provided_list(Scheme_Object *o, int count, intptr_t *lenout);
- static char *init_buf(intptr_t *len, intptr_t *blen);
- void scheme_set_logging2(int syslog_level, int stderr_level, int stdout_level)
- {
- if (syslog_level > -1)
- init_syslog_level = scheme_make_integer(syslog_level);
- if (stderr_level > -1)
- init_stderr_level = scheme_make_integer(stderr_level);
- if (stdout_level > -1)
- init_stdout_level = scheme_make_integer(stdout_level);
- }
- void scheme_set_logging(int syslog_level, int stderr_level)
- {
- scheme_set_logging2(syslog_level, stderr_level, -1);
- }
-
- void scheme_set_logging2_spec(Scheme_Object *syslog_level, Scheme_Object *stderr_level, Scheme_Object *stdout_level)
- {
- /* A spec is (list* <int> <byte-string> .... <int>) */
- if (syslog_level) {
- REGISTER_SO(init_syslog_level);
- init_syslog_level = syslog_level;
- }
- if (stderr_level) {
- REGISTER_SO(init_stderr_level);
- init_stderr_level = stderr_level;
- }
- if (stdout_level) {
- REGISTER_SO(init_stdout_level);
- init_stdout_level = stdout_level;
- }
- }
- void scheme_set_logging_spec(Scheme_Object *syslog_level, Scheme_Object *stderr_level)
- {
- scheme_set_logging2_spec(syslog_level, stderr_level, NULL);
- }
- void scheme_init_logging_once(void)
- {
- /* Convert specs to use symbols */
- int j;
- Scheme_Object *l, *s;
- for (j = 0; j < 3; j++) {
- switch (j) {
- case 0: l = init_syslog_level; break;
- case 1: l = init_stderr_level; break;
- default: l = init_stdout_level; break;
- }
- if (l) {
- while (!SCHEME_INTP(l)) {
- l = SCHEME_CDR(l);
- s = scheme_intern_exact_symbol(SCHEME_BYTE_STR_VAL(SCHEME_CAR(l)),
- SCHEME_BYTE_STRLEN_VAL(SCHEME_CAR(l)));
- SCHEME_CAR(l) = s;
- l = SCHEME_CDR(l);
- }
- }
- }
- }
- typedef struct {
- int args;
- Scheme_Object *type;
- Scheme_Object **names;
- int count;
- Scheme_Object *exptime;
- int super_pos;
- } exn_rec;
- #define _MZEXN_TABLE
- #include "schexn.h"
- #undef _MZEXN_TABLE
- static void default_printf(char *msg, ...)
- {
- GC_CAN_IGNORE va_list args;
- HIDE_FROM_XFORM(va_start(args, msg));
- vfprintf(stderr, msg, args);
- HIDE_FROM_XFORM(va_end(args));
- fflush(stderr);
- }
- static void default_output(char *s, intptr_t len)
- {
- fwrite(s, len, 1, stderr);
- fflush(stderr);
- }
- intptr_t scheme_errno() {
- #ifdef WINDOWS_FILE_HANDLES
- return GetLastError();
- #else
- return errno;
- #endif
- }
- Scheme_Config *scheme_init_error_escape_proc(Scheme_Config *config)
- {
- if (!def_error_esc_proc) {
- REGISTER_SO(def_error_esc_proc);
- def_error_esc_proc =
- scheme_make_prim_w_arity((Scheme_Prim *)def_error_escape_proc,
- "default-error-escape-handler",
- 0, 0);
- }
- if (config)
- return scheme_extend_config(config, MZCONFIG_ERROR_ESCAPE_HANDLER, def_error_esc_proc);
- else {
- scheme_set_root_param(MZCONFIG_ERROR_ESCAPE_HANDLER, def_error_esc_proc);
- return NULL;
- }
- }
- /*
- Recognized by scheme_[v]sprintf:
- %c = unicode char
- %d = int
- %gd = long int
- %gx = long int
- %ld = intptr_t
- %Id = intptr_t (for MSVC)
- %I64d = intptr_t (for MingGW)
- %lx = intptr_t
- %Ix = intptr_t (for MSVC)
- %I64x = intptr_t (for MingGW)
- %o = int, octal
- %f = double
- %% = percent
- %s = string
- %5 = mzchar string
- %S = Scheme symbol
- %t = string with inptr_t size
- %u = mzchar string with intptr_t size
- %T = Scheme string
- %q = truncated-to-256 string
- %Q = truncated-to-256 Scheme string
- %V = scheme_value
- %@ = list of scheme_value to write splice
- %D = scheme value to display
- %W = scheme value to write
- %_ = skip pointer
- %- = skip int
- %L = line number as intptr_t, -1 means no line
- %R = get error number and string from rktio
- %e = error number for strerror()
- %E = error number for platform-specific error string
- %Z = potential platform-specific error number; additional char*
- is either NULL or a specific error message
- %N = boolean then error number like %E (if boolean is 0)
- or error number for scheme_hostname_error()
- %m = boolean then error number like %e, which
- is used only if the boolean is 1
- %M = boolean then error number like %E, which
- is used only if the boolean is 1
- */
- static intptr_t sch_vsprintf(char *s, intptr_t maxlen, const char *msg, va_list args, char **_s,
- Scheme_Object **_errno_val, int *_unsupported)
- /* NULL for s means allocate the buffer here (and return in (_s), but this function
- doesn't allocate before extracting arguments from the stack. */
- {
- intptr_t i, j;
- char buf[100];
- /* Since we might malloc, move all pointers into a local array for
- the sake of precise GC. We have to do numbers, too, for
- consistency. */
- int pp = 0, ip = 0, dp = 0;
- void *ptrs[25];
- intptr_t ints[25];
- double dbls[25];
- for (j = 0; msg[j]; j++) {
- if (msg[j] == '%') {
- int type;
- j++;
- type = msg[j];
- switch (type) {
- case 'c':
- ints[ip++] = mzVA_ARG(args, int);
- break;
- case 'd':
- case 'o':
- case '-':
- ints[ip++] = mzVA_ARG(args, int);
- break;
- case 'g':
- ints[ip++] = mzVA_ARG(args, long);
- break;
- case 'l':
- case 'I':
- ints[ip++] = mzVA_ARG(args, intptr_t);
- break;
- case 'f':
- dbls[dp++] = mzVA_ARG(args, double);
- break;
- case 'L':
- ints[ip++] = mzVA_ARG(args, intptr_t);
- break;
- case 'e':
- case 'E':
- ints[ip++] = mzVA_ARG(args, int);
- break;
- case 'N':
- case 'm':
- case 'M':
- ints[ip++] = mzVA_ARG(args, int);
- ints[ip++] = mzVA_ARG(args, int);
- break;
- case 'Z':
- ints[ip++] = mzVA_ARG(args, int);
- ptrs[pp++] = mzVA_ARG(args, char*);
- break;
- case 'S':
- case 'V':
- case '@':
- case 'D':
- case 'W':
- case 'T':
- case 'Q':
- case '_':
- ptrs[pp++] = mzVA_ARG(args, Scheme_Object*);
- break;
- default:
- ptrs[pp++] = mzVA_ARG(args, char*);
- if ((type == 't') || (type == 'u')) {
- ints[ip++] = mzVA_ARG(args, intptr_t);
- }
- }
- }
- }
- pp = 0;
- ip = 0;
- dp = 0;
- if (!s) {
- s = init_buf(NULL, &maxlen);
- *_s = s;
- }
- --maxlen;
- i = j = 0;
- while ((i < maxlen) && msg[j]) {
- if (msg[j] == '%') {
- int type;
- j++;
- type = msg[j++];
- if (type == '%')
- s[i++] = '%';
- else {
- const char *t;
- intptr_t tlen;
- int dots = 0;
- switch (type) {
- case 'c':
- {
- int c;
- c = ints[ip++];
- if (c < 128) {
- buf[0] = c;
- tlen = 1;
- } else {
- mzchar mc;
- mc = c;
- tlen = scheme_utf8_encode_all(&mc, 1, (unsigned char *)buf);
- }
- t = buf;
- }
- break;
- case 'd':
- {
- int d;
- d = ints[ip++];
- sprintf(buf, "%d", d);
- t = buf;
- tlen = strlen(t);
- }
- break;
- case '-':
- {
- ip++;
- t = "";
- tlen = 0;
- }
- break;
- case 'o':
- {
- int d;
- d = ints[ip++];
- sprintf(buf, "%o", d);
- t = buf;
- tlen = strlen(t);
- }
- break;
- case 'I':
- case 'l':
- case 'g':
- {
- intptr_t d;
- int as_hex;
- if ((type == 'I') && (msg[j] == '6') && (msg[j+1] == '4'))
- j++;
- as_hex = (msg[j] == 'x');
- j++;
- d = ints[ip++];
- if (as_hex)
- sprintf(buf, "%" PRIxPTR, d);
- else
- sprintf(buf, "%" PRIdPTR, d);
- t = buf;
- tlen = strlen(t);
- }
- break;
- case 'f':
- {
- double f;
- f = dbls[dp++];
- sprintf(buf, "%f", f);
- t = buf;
- tlen = strlen(t);
- }
- break;
- case 'L':
- {
- intptr_t d;
- d = ints[ip++];
- if (d >= 0) {
- sprintf(buf, "%" PRIdPTR ":", d);
- t = buf;
- tlen = strlen(t);
- } else {
- t = ":";
- tlen = 1;
- }
- }
- break;
- case 'R':
- {
- intptr_t errid;
- intptr_t errkind;
- const char *es, *errkind_str;
- intptr_t elen;
- errkind = rktio_get_last_error_kind(scheme_rktio);
- errid = rktio_get_last_error(scheme_rktio);
- switch (errkind) {
- case RKTIO_ERROR_KIND_WINDOWS:
- errkind_str = "errid";
- break;
- case RKTIO_ERROR_KIND_POSIX:
- errkind_str = "errno";
- break;
- case RKTIO_ERROR_KIND_GAI:
- errkind_str = "gai_err";
- break;
- default:
- errkind_str = "rktio_err";
- break;
- }
- es = rktio_get_error_string(scheme_rktio, errkind, errid);
- sprintf(buf, "; %s=%" PRIdPTR "", errkind_str, errid);
- if (es) elen = strlen(es); else elen = 0;
- tlen = strlen(buf);
- t = (const char *)scheme_malloc_atomic(tlen+elen+1);
- memcpy((char *)t, es, elen);
- memcpy((char *)t+elen, buf, tlen+1);
- tlen += elen;
- if (_errno_val) {
- Scheme_Object *err_kind;
- switch (errkind) {
- case RKTIO_ERROR_KIND_WINDOWS:
- err_kind = windows_symbol;
- break;
- case RKTIO_ERROR_KIND_POSIX:
- err_kind = posix_symbol;
- break;
- case RKTIO_ERROR_KIND_GAI:
- err_kind = gai_symbol;
- break;
- default:
- err_kind = NULL;
- }
- if (err_kind) {
- err_kind = scheme_make_pair(scheme_make_integer_value(errid), err_kind);
- *_errno_val = err_kind;
- }
- }
- if (_unsupported
- && (errid == RKTIO_ERROR_UNSUPPORTED)
- && (errkind == RKTIO_ERROR_KIND_RACKET))
- *_unsupported = 1;
- }
- break;
- case 'e':
- case 'm':
- case 'E':
- case 'M':
- case 'Z':
- case 'N':
- {
- int en, he, none = 0;
- char *es;
- const char *errkind_str = NULL;
- Scheme_Object *err_kind = NULL;
-
- if (type == 'm') {
- none = !ints[ip++];
- type = 'e';
- he = 0;
- } else if (type == 'M') {
- none = !ints[ip++];
- type = 'E';
- he = 0;
- } else if (type == 'N') {
- he = ints[ip++];
- type = 'E';
- } else
- he = 0;
- en = ints[ip++];
- if (type == 'Z')
- es = ptrs[pp++];
- else
- es = NULL;
- if (he) {
- es = (char *)scheme_hostname_error(en);
- err_kind = gai_symbol;
- errkind_str = "gai_err";
- }
- if ((en || es) && !none) {
- #ifdef NO_STRERROR_AVAILABLE
- if (!es)
- es = "Unknown error";
- err_kind = posix_symbol;
- #else
- # ifdef DOS_FILE_SYSTEM
- wchar_t mbuf[256];
- int len;
- if ((type != 'e') && !es) {
- if ((len = FormatMessageW((FORMAT_MESSAGE_FROM_SYSTEM
- | FORMAT_MESSAGE_IGNORE_INSERTS),
- NULL,
- en, MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
- mbuf, 255, NULL))) {
- int i;
- i = scheme_utf8_encode((const unsigned int *)mbuf, 0, len, NULL, 0, 1);
- es = (char *)scheme_malloc_atomic(i + 1);
- (void)scheme_utf8_encode((const unsigned int *)mbuf, 0, len, es, 0, 1);
- es[i] = 0;
- /* Remove newlines: */
- for (i = strlen(es) - 1; i > 0; i--) {
- if (isspace(es[i]))
- es[i] = 0;
- else
- break;
- }
- err_kind = windows_symbol;
- errkind_str = "win_err";
- }
- }
- # endif
- if (!es) {
- es = strerror(en);
- err_kind = posix_symbol;
- errkind_str = "errno";
- }
- #endif
- tlen = strlen(es) + 24;
- t = (const char *)scheme_malloc_atomic(tlen);
- MZ_ASSERT(errkind_str);
- sprintf((char *)t, "%s; %s=%d", es, errkind_str, en);
- tlen = strlen(t);
- if (_errno_val) {
- err_kind = scheme_make_pair(scheme_make_integer_value(en), err_kind);
- *_errno_val = err_kind;
- }
- } else {
- if (none) {
- t = "";
- tlen = 0;
- } else {
- t = "errno=?";
- tlen = 7;
- }
- }
- }
- break;
- case 'S':
- {
- Scheme_Object *sym;
- sym = (Scheme_Object *)ptrs[pp++];
- t = scheme_symbol_name_and_size(sym, (uintptr_t *)&tlen, 0);
- }
- break;
- case 'V':
- {
- Scheme_Object *o;
- o = (Scheme_Object *)ptrs[pp++];
- t = scheme_make_provided_string(o, 1, &tlen);
- }
- break;
- case '@':
- {
- Scheme_Object *o;
- o = (Scheme_Object *)ptrs[pp++];
- t = make_provided_list(o, 1, &tlen);
- }
- break;
- case 'D':
- {
- Scheme_Object *o;
- intptr_t dlen;
- o = (Scheme_Object *)ptrs[pp++];
- t = scheme_display_to_string(o, &dlen);
- tlen = dlen;
- }
- break;
- case 'W':
- {
- Scheme_Object *o;
- intptr_t dlen;
- o = (Scheme_Object *)ptrs[pp++];
- t = scheme_write_to_string(o, &dlen);
- tlen = dlen;
- }
- break;
- case '_':
- {
- pp++;
- t = "";
- tlen = 0;
- }
- break;
- case 'T':
- case 'Q':
- {
- Scheme_Object *str;
- str = (Scheme_Object *)ptrs[pp++];
- if (SCHEME_CHAR_STRINGP(str))
- str = scheme_char_string_to_byte_string(str);
- t = SCHEME_BYTE_STR_VAL(str);
- tlen = SCHEME_BYTE_STRLEN_VAL(str);
- }
- break;
- case 'u':
- case '5':
- {
- mzchar *u;
- intptr_t ltlen;
- u = (mzchar *)ptrs[pp++];
- if (type == 'u') {
- tlen = ints[ip++];
- if (tlen < 0)
- tlen = scheme_char_strlen(u);
- } else {
- tlen = scheme_char_strlen(u);
- }
- t = scheme_utf8_encode_to_buffer_len(u, tlen, NULL, 0, <len);
- tlen = ltlen;
- }
- break;
- default:
- {
- t = (char *)ptrs[pp++];
- if (type == 't') {
- tlen = ints[ip++];
- if (tlen < 0)
- tlen = strlen(t);
- } else {
- tlen = strlen(t);
- }
- }
- break;
- }
- if ((type == 'q') || (type == 'Q')) {
- if (tlen > 256) {
- tlen = 250;
- dots = 1;
- }
- }
- while (tlen && i < maxlen) {
- s[i++] = *t;
- t = t XFORM_OK_PLUS 1;
- tlen--;
- }
- if (dots) {
- /* FIXME: avoiding truncating in the middle of a UTF-8 encoding */
- if (i < maxlen - 3) {
- s[i++] = '.';
- s[i++] = '.';
- s[i++] = '.';
- }
- }
- }
- } else {
- s[i++] = msg[j++];
- }
- }
- s[i] = 0;
- return i;
- }
- intptr_t scheme_sprintf(char *s, intptr_t maxlen, const char *msg, ...)
- {
- intptr_t len;
- GC_CAN_IGNORE va_list args;
- HIDE_FROM_XFORM(va_start(args, msg));
- len = sch_vsprintf(s, maxlen, msg, args, NULL, NULL, NULL);
- HIDE_FROM_XFORM(va_end(args));
- return len;
- }
- int scheme_last_error_is_racket(int errid)
- {
- return ((rktio_get_last_error_kind(scheme_rktio) == RKTIO_ERROR_KIND_RACKET)
- && (rktio_get_last_error(scheme_rktio) == errid));
- }
- #define ESCAPING_NONCM_PRIM(name, func, a1, a2, env) \
- p = scheme_make_noncm_prim(func, name, a1, a2); \
- SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_ALWAYS_ESCAPES); \
- scheme_addto_prim_instance(name, p, env);
- void scheme_init_error(Scheme_Startup_Env *env)
- {
- Scheme_Object *p;
- if (!scheme_console_printf)
- scheme_console_printf = default_printf;
- if (!scheme_console_output)
- scheme_console_output = default_output;
- REGISTER_SO(scheme_raise_arity_error_proc);
- /* errors */
- ESCAPING_NONCM_PRIM("error", error, 1, -1, env);
- ESCAPING_NONCM_PRIM("raise-user-error", raise_user_error, 1, -1, env);
- ESCAPING_NONCM_PRIM("raise-type-error", raise_type_error, 3, -1, env);
- ESCAPING_NONCM_PRIM("raise-argument-error", raise_argument_error, 3, -1, env);
- ESCAPING_NONCM_PRIM("raise-result-error", raise_result_error, 3, -1, env);
- ESCAPING_NONCM_PRIM("raise-arguments-error", raise_arguments_error, 2, -1, env);
- ESCAPING_NONCM_PRIM("raise-mismatch-error", raise_mismatch_error, 3, -1, env);
- ESCAPING_NONCM_PRIM("raise-range-error", raise_range_error, 7, 8, env);
- scheme_raise_arity_error_proc = scheme_make_noncm_prim(raise_arity_error, "raise-arity-error", 2, -1);
- scheme_addto_prim_instance("raise-arity-error", scheme_raise_arity_error_proc, env);
- ESCAPING_NONCM_PRIM("raise-arity-mask-error", raise_arity_mask_error, 2, -1, env);
- ESCAPING_NONCM_PRIM("raise-result-arity-error", raise_result_arity_error, 3, -1, env);
- ADD_PARAMETER("error-display-handler", error_display_handler, MZCONFIG_ERROR_DISPLAY_HANDLER, env);
- ADD_PARAMETER("error-value->string-handler", error_value_string_handler, MZCONFIG_ERROR_PRINT_VALUE_HANDLER, env);
- ADD_PARAMETER("error-escape-handler", error_escape_handler, MZCONFIG_ERROR_ESCAPE_HANDLER, env);
- ADD_PARAMETER("exit-handler", exit_handler, MZCONFIG_EXIT_HANDLER, env);
- ADD_PARAMETER("executable-yield-handler", exe_yield_handler, MZCONFIG_EXE_YIELD_HANDLER, env);
- ADD_PARAMETER("error-print-width", error_print_width, MZCONFIG_ERROR_PRINT_WIDTH, env);
- ADD_PARAMETER("error-print-context-length", error_print_context_length, MZCONFIG_ERROR_PRINT_CONTEXT_LENGTH, env);
- ADD_PARAMETER("error-print-source-location", error_print_srcloc, MZCONFIG_ERROR_PRINT_SRCLOC, env);
- ADD_NONCM_PRIM("exit", scheme_do_exit, 0, 1, env);
- /* logging */
- ADD_NONCM_PRIM("log-level?", log_level_p, 2, 3, env);
- ADD_NONCM_PRIM("log-max-level", log_max_level, 1, 2, env);
- ADD_NONCM_PRIM("log-all-levels", log_all_levels, 1, 1, env);
- ADD_NONCM_PRIM("log-level-evt", log_level_evt, 1, 1, env);
- ADD_NONCM_PRIM("make-logger", make_logger, 0, -1, env);
- ADD_NONCM_PRIM("make-log-receiver", make_log_reader, 2, -1, env);
- ADD_PRIM_W_ARITY("log-message", log_message, 3, 6, env);
- ADD_FOLDING_PRIM("logger?", logger_p, 1, 1, 1, env);
- ADD_FOLDING_PRIM("logger-name", logger_name, 1, 1, 1, env);
- ADD_FOLDING_PRIM("log-receiver?", log_reader_p, 1, 1, 1, env);
- ADD_PARAMETER("current-logger", current_logger, MZCONFIG_LOGGER, env);
- ADD_NONCM_PRIM("srcloc->string", srcloc_to_string, 1, 1, env);
- ADD_NONCM_PRIM("unquoted-printing-string", unquoted_printing_string, 1, 1, env);
- ADD_FOLDING_PRIM("unquoted-printing-string?", unquoted_printing_string_p, 1, 1, 1, env);
- ADD_IMMED_PRIM("unquoted-printing-string-value", unquoted_printing_string_value, 1, 1, env);
- REGISTER_SO(scheme_def_exit_proc);
- REGISTER_SO(default_display_handler);
- REGISTER_SO(emergency_display_handler);
- scheme_def_exit_proc = scheme_make_prim_w_arity(def_exit_handler_proc, "default-exit-handler", 1, 1);
- default_display_handler = scheme_make_prim_w_arity(def_error_display_proc, "default-error-display-handler", 2, 2);
- emergency_display_handler = scheme_make_prim_w_arity(emergency_error_display_proc, "emergency-error-display-handler", 2, 2);
-
- REGISTER_SO(def_err_val_proc);
- def_err_val_proc = scheme_make_prim_w_arity(def_error_value_string_proc, "default-error-value->string-handler", 2, 2);
- REGISTER_SO(none_symbol);
- REGISTER_SO(fatal_symbol);
- REGISTER_SO(error_symbol);
- REGISTER_SO(warning_symbol);
- REGISTER_SO(info_symbol);
- REGISTER_SO(debug_symbol);
- none_symbol = scheme_intern_symbol("none");
- fatal_symbol = scheme_intern_symbol("fatal");
- error_symbol = scheme_intern_symbol("error");
- warning_symbol = scheme_intern_symbol("warning");
- info_symbol = scheme_intern_symbol("info");
- debug_symbol = scheme_intern_symbol("debug");
- REGISTER_SO(posix_symbol);
- REGISTER_SO(windows_symbol);
- REGISTER_SO(gai_symbol);
- posix_symbol = scheme_intern_symbol("posix");
- windows_symbol = scheme_intern_symbol("windows");
- gai_symbol = scheme_intern_symbol("gai");
- REGISTER_SO(arity_property);
- {
- Scheme_Object *guard;
- guard = scheme_make_prim_w_arity(check_arity_property_value_ok, "guard-for-prop:arity-string", 2, 2);
- arity_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("arity-string"), guard);
- }
-
- scheme_addto_prim_instance("prop:arity-string", arity_property, env);
- REGISTER_SO(def_exe_yield_proc);
- def_exe_yield_proc = scheme_make_prim_w_arity(default_yield_handler,
- "default-executable-yield-handler",
- 1, 1);
- }
- void scheme_init_logger_wait()
- {
- scheme_add_evt(scheme_log_reader_type, (Scheme_Ready_Fun)log_reader_get, NULL, NULL, 1);
- }
- void scheme_init_logger()
- {
- REGISTER_SO(scheme_main_logger);
- scheme_main_logger = scheme_make_logger(NULL, NULL);
- scheme_main_logger->syslog_level = init_syslog_level;
- scheme_main_logger->stderr_level = init_stderr_level;
- scheme_main_logger->stdout_level = init_stdout_level;
- REGISTER_SO(scheme_gc_logger);
- scheme_gc_logger = scheme_make_logger(scheme_main_logger, scheme_intern_symbol("GC"));
- REGISTER_SO(scheme_future_logger);
- scheme_future_logger = scheme_make_logger(scheme_main_logger, scheme_intern_symbol("future"));
- REGISTER_SO(scheme_place_logger);
- scheme_place_logger = scheme_make_logger(scheme_main_logger, scheme_intern_symbol("place"));
- }
- Scheme_Logger *scheme_get_main_logger() {
- return scheme_main_logger;
- }
- Scheme_Logger *scheme_get_gc_logger() {
- return scheme_gc_logger;
- }
- Scheme_Logger *scheme_get_future_logger() {
- return scheme_future_logger;
- }
- Scheme_Logger *scheme_get_place_logger() {
- return scheme_place_logger;
- }
- void scheme_init_error_config(void)
- {
- scheme_set_root_param(MZCONFIG_EXIT_HANDLER, scheme_def_exit_proc);
- scheme_set_root_param(MZCONFIG_ERROR_DISPLAY_HANDLER, default_display_handler);
- scheme_set_root_param(MZCONFIG_ERROR_PRINT_VALUE_HANDLER, def_err_val_proc);
- scheme_set_root_param(MZCONFIG_EXE_YIELD_HANDLER, def_exe_yield_proc);
- }
- void scheme_init_logger_config() {
- scheme_set_root_param(MZCONFIG_LOGGER, (Scheme_Object *)scheme_main_logger);
- }
- static MZ_NORETURN void
- call_error(char *buffer, int len, Scheme_Object *exn)
- {
- if (scheme_current_thread->constant_folding) {
- if (scheme_current_thread->constant_folding != (Optimize_Info *)scheme_false)
- scheme_log(scheme_optimize_info_logger(scheme_current_thread->constant_folding),
- SCHEME_LOG_WARNING,
- 0,
- "constant-fold attempt failed%s: %s",
- scheme_optimize_info_context(scheme_current_thread->constant_folding),
- buffer);
- if (SCHEME_CHAPERONE_STRUCTP(exn)
- && scheme_is_struct_instance(exn_table[MZEXN_BREAK].type, exn)) {
- /* remember to re-raise exception */
- scheme_current_thread->reading_delayed = exn;
- }
- scheme_longjmp(scheme_error_buf, 1);
- } else if (scheme_current_thread->reading_delayed) {
- scheme_current_thread->reading_delayed = exn;
- scheme_longjmp(scheme_error_buf, 1);
- } else {
- mz_jmp_buf savebuf;
- Scheme_Object *p[2], *display_handler, *escape_handler, *v;
- Scheme_Config *config, *orig_config;
- Scheme_Cont_Frame_Data cframe, cframe2;
- /* For last resort: */
- memcpy((void *)&savebuf, &scheme_error_buf, sizeof(mz_jmp_buf));
- orig_config = scheme_current_config();
- display_handler = scheme_get_param(orig_config, MZCONFIG_ERROR_DISPLAY_HANDLER);
- escape_handler = scheme_get_param(orig_config, MZCONFIG_ERROR_ESCAPE_HANDLER);
-
- v = scheme_make_byte_string_without_copying("error display handler");
- v = scheme_make_closed_prim_w_arity((Scheme_Closed_Prim *)nested_exn_handler,
- scheme_make_pair(v, exn),
- "nested-exception-handler",
- 1, 1);
- config = orig_config;
- if (SAME_OBJ(display_handler, default_display_handler))
- config = scheme_extend_config(config,
- MZCONFIG_ERROR_DISPLAY_HANDLER,
- emergency_display_handler);
- else
- config = scheme_extend_config(config,
- MZCONFIG_ERROR_DISPLAY_HANDLER,
- default_display_handler);
-
- scheme_push_continuation_frame(&cframe);
- scheme_install_config(config);
- scheme_set_cont_mark(scheme_exn_handler_key, v);
- scheme_push_break_enable(&cframe2, 0, 0);
- if (SCHEME_CHAPERONE_STRUCTP(exn)
- && (scheme_is_struct_instance(exn_table[MZEXN_BREAK_HANG_UP].type, exn))) {
- /* skip printout */
- } else {
- p[0] = scheme_make_immutable_sized_utf8_string(buffer, len);
- p[1] = exn;
- scheme_apply_multi(display_handler, 2, p);
- }
- if (SCHEME_CHAPERONE_STRUCTP(exn)
- && (scheme_is_struct_instance(exn_table[MZEXN_BREAK_HANG_UP].type, exn)
- || scheme_is_struct_instance(exn_table[MZEXN_BREAK_TERMINATE].type, exn))) {
- /* Default uncaught exception handler exits on `exn:break:hang-up'
- or `exn:break:terminate'. */
- p[0] = scheme_make_integer(1);
- scheme_do_exit(1, p);
- /* Fall through to regular escape if the exit handler doesn't exit/escape. */
- }
- v = scheme_make_byte_string_without_copying("error escape handler");
- v = scheme_make_closed_prim_w_arity((Scheme_Closed_Prim *)nested_exn_handler,
- scheme_make_pair(v, exn),
- "nested-exception-handler",
- 1, 1);
-
- config = scheme_extend_config(config,
- MZCONFIG_ERROR_DISPLAY_HANDLER,
- default_display_handler);
- config = scheme_extend_config(config,
- MZCONFIG_ERROR_ESCAPE_HANDLER,
- def_error_esc_proc);
-
- scheme_pop_break_enable(&cframe2, 0);
- scheme_pop_continuation_frame(&cframe);
- scheme_push_continuation_frame(&cframe);
- scheme_set_cont_mark(scheme_exn_handler_key, v);
- scheme_install_config(config);
- scheme_push_break_enable(&cframe2, 0, 0);
- /* Typically jumps out of here */
- scheme_apply_multi(escape_handler, 0, NULL);
- scheme_pop_break_enable(&cframe2, 0);
- scheme_pop_continuation_frame(&cframe);
- /* Didn't escape, so fall back to the default escaper: */
- def_error_escape_proc(0, NULL);
- }
- }
- intptr_t scheme_get_print_width(void)
- {
- intptr_t print_width;
- Scheme_Object *w;
- w = scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PRINT_WIDTH);
- if (SCHEME_INTP(w))
- print_width = SCHEME_INT_VAL(w);
- else if (SCHEME_BIGNUMP(w))
- print_width = 0x7FFFFFFF;
- else
- print_width = 10000;
- return print_width;
- }
- static char *init_buf(intptr_t *len, intptr_t *_size)
- {
- uintptr_t local_max_symbol_length;
- intptr_t print_width;
- intptr_t size;
-
- local_max_symbol_length = scheme_get_max_symbol_length();
- print_width = scheme_get_print_width();
- size = (3 * local_max_symbol_length + 500 + 2 * print_width);
- /* out parameters */
- if (len)
- *len = print_width;
- if (_size)
- *_size = size;
- return (char *)scheme_malloc_atomic(size);
- }
- void
- scheme_signal_error (const char *msg, ...)
- {
- GC_CAN_IGNORE va_list args;
- char *buffer;
- intptr_t len;
- HIDE_FROM_XFORM(va_start(args, msg));
- len = sch_vsprintf(NULL, 0, msg, args, &buffer, NULL, NULL);
- HIDE_FROM_XFORM(va_end(args));
- buffer[len] = 0;
- if (scheme_starting_up) {
- buffer[len++] = '\n';
- buffer[len] = 0;
- scheme_console_output(buffer, len);
- exit(0);
- }
- scheme_raise_exn(MZEXN_FAIL, "%t", buffer, len);
- }
- void scheme_warning(char *msg, ...)
- {
- GC_CAN_IGNORE va_list args;
- char *buffer;
- intptr_t len;
- HIDE_FROM_XFORM(va_start(args, msg));
- len = sch_vsprintf(NULL, 0, msg, args, &buffer, NULL, NULL);
- HIDE_FROM_XFORM(va_end(args));
- buffer[len++] = '\n';
- buffer[len] = 0;
- scheme_write_byte_string(buffer, len,
- scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PORT));
- }
- void scheme_ensure_console_ready()
- {
- rktio_create_console();
- }
- void scheme_log(Scheme_Logger *logger, int level, int flags,
- const char *msg, ...)
- {
- GC_CAN_IGNORE va_list args;
- char *buffer;
- intptr_t len;
- if (logger) {
- if (logger->local_timestamp == SCHEME_INT_VAL(logger->root_timestamp[0]))
- if (logger->want_level < level)
- return;
- }
- HIDE_FROM_XFORM(va_start(args, msg));
- len = sch_vsprintf(NULL, 0, msg, args, &buffer, NULL, NULL);
- HIDE_FROM_XFORM(va_end(args));
- buffer[len] = 0;
- scheme_log_message(logger, level, buffer, len, NULL);
- }
- void scheme_log_w_data(Scheme_Logger *logger, int level, int flags,
- Scheme_Object *data,
- const char *msg, ...)
- {
- GC_CAN_IGNORE va_list args;
- char *buffer;
- intptr_t len;
- if (logger) {
- if (logger->local_timestamp == SCHEME_INT_VAL(logger->root_timestamp[0]))
- if (logger->want_level < level)
- return;
- }
- HIDE_FROM_XFORM(va_start(args, msg));
- len = sch_vsprintf(NULL, 0, msg, args, &buffer, NULL, NULL);
- HIDE_FROM_XFORM(va_end(args));
- buffer[len] = 0;
- scheme_log_message(logger, level, buffer, len, data);
- }
- static char *error_write_to_string_w_max(Scheme_Object *v, int len, intptr_t *lenout)
- {
- Scheme_Object *o, *args[2];
- o = scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PRINT_VALUE_HANDLER);
- if ((SAME_OBJ(o, def_err_val_proc)
- && SAME_OBJ(scheme_get_param(scheme_current_config(), MZCONFIG_PORT_PRINT_HANDLER),
- scheme_default_global_print_handler))) {
- intptr_t l;
- char *s;
- s = scheme_print_to_string_w_max(v, &l, len);
- if (lenout)
- *lenout = l;
- return s;
- } else {
- Scheme_Config *config;
- Scheme_Cont_Frame_Data cframe, cframe2;
- args[0] = v;
- args[1] = scheme_make_integer(len);
- config = scheme_extend_config(scheme_current_config(),
- MZCONFIG_ERROR_PRINT_VALUE_HANDLER,
- def_err_val_proc);
- config = scheme_extend_config(config,
- MZCONFIG_PRINT_UNREADABLE,
- scheme_true);
- scheme_push_continuation_frame(&cframe);
- scheme_install_config(config);
- scheme_push_break_enable(&cframe2, 0, 0);
- o = _scheme_apply(o, 2, args);
- scheme_pop_break_enable(&cframe2, 0);
- scheme_pop_continuation_frame(&cframe);
- if (SCHEME_CHAR_STRINGP(o)) {
- o = scheme_char_string_to_byte_string(o);
- }
- if (SCHEME_BYTE_STRINGP(o)) {
- char *s = SCHEME_BYTE_STR_VAL(o);
- if (SCHEME_BYTE_STRTAG_VAL(o) > len) {
- char *naya;
- naya = scheme_malloc_atomic(len + 1);
- memcpy(naya, s, len);
- s[len] = 0;
- if (lenout)
- *lenout = len;
- } else if (lenout)
- *lenout = SCHEME_BYTE_STRTAG_VAL(o);
- return s;
- } else {
- if (lenout)
- *lenout = 3;
- return "...";
- }
- }
- }
- static Scheme_Object *check_arity_property_value_ok(int argc, Scheme_Object *argv[])
- {
- if (!scheme_check_proc_arity(NULL, 1, 0, 1, argv))
- scheme_arg_mismatch("guard-for-prop:arity-string",
- "property value is not a procedure (arity 1): ",
- argv[0]);
- return argv[0];
- }
- static char *make_arity_expect_string(const char *name, int namelen,
- int minc, int maxc,
- int argc, Scheme_Object **argv,
- intptr_t *_len, int is_method,
- const char *map_name)
- /* minc == -1 => name is really a case-lambda, native closure, or proc-struct.
- minc == -2 => use generic arity-mismatch message */
- {
- intptr_t len, pos, slen;
- int xargc, xminc, xmaxc;
- char *s, *arity_str = NULL;
- const char *prefix_msg1, *prefix_msg2, *suffix_msg;
- int arity_len = 0;
- s = init_buf(&len, &slen);
- if (!name)
- name = "#<procedure>";
- xargc = argc - (is_method ? 1 : 0);
- xminc = minc - (is_method ? 1 : 0);
- xmaxc = maxc - (is_method ? 1 : 0);
- if ((minc == -1) && SCHEME_CHAPERONE_PROC_STRUCTP((Scheme_Object *)name)) {
- Scheme_Object *arity_maker;
- while (1) {
- arity_maker = scheme_struct_type_property_ref(arity_property, (Scheme_Object *)name);
- if (arity_maker) {
- Scheme_Object *v, *a[1];
- a[0] = (Scheme_Object *)name;
- v = scheme_apply(arity_maker, 1, a);
- if (SCHEME_CHAR_STRINGP(v)) {
- v = scheme_char_string_to_byte_string(v);
- arity_str = SCHEME_BYTE_STR_VAL(v);
- arity_len = SCHEME_BYTE_STRLEN_VAL(v);
- if (arity_len > len)
- arity_len = len;
- name = scheme_get_proc_name((Scheme_Object *)name, &namelen, 1);
- if (!name) {
- name = "#<procedure>";
- namelen = strlen(name);
- }
- break;
- } else
- break;
- } else {
- Scheme_Object *v;
- int is_method;
- v = (Scheme_Object *)name;
- if (SCHEME_CHAPERONEP(v))
- v = SCHEME_CHAPERONE_VAL(v);
- if (scheme_is_struct_instance(scheme_reduced_procedure_struct, v))
- v = NULL; /* hide any wider type that a nested structure might report */
- else
- v = scheme_extract_struct_procedure(v, -1, NULL, &is_method);
- if (!v || is_method || !SCHEME_CHAPERONE_PROC_STRUCTP(v))
- break;
- name = (const char *)v;
- }
- SCHEME_USE_FUEL(1);
- }
- if (!arity_str) {
- /* If the arity is something simple, we'll make a good error
- message. Otherwise, we'll just use the "no matching case"
- version. */
- Scheme_Object *arity;
- arity = scheme_arity((Scheme_Object *)name);
- if (SCHEME_INTP(arity)) {
- minc = maxc = SCHEME_INT_VAL(arity);
- xmaxc = xminc = minc - (is_method ? 1 : 0);
- name = scheme_get_proc_name((Scheme_Object *)name, &namelen, 1);
- if (!name) {
- name = "#<procedure>";
- namelen = strlen(name);
- }
- }
- }
- }
- if (map_name) {
- prefix_msg1 = map_name;
- prefix_msg2 = (": argument mismatch;\n"
- " the given procedure's expected number of arguments does not match\n"
- " the given number of lists\n"
- " given procedure: ");
- suffix_msg = "";
- } else {
- prefix_msg1 = "";
- prefix_msg2 = "";
- suffix_msg = (": arity mismatch;\n"
- " the expected number of arguments does not match the given number");
- }
- if (arity_str) {
- pos = scheme_sprintf(s, slen,
- "%s%s%t%s\n"
- " expected: %t\n"
- " given: %d",
- prefix_msg1, prefix_msg2,
- name, (intptr_t)namelen,
- suffix_msg,
- arity_str, (intptr_t)arity_len, xargc);
- } else if (minc < 0) {
- const char *n;
- int nlen;
- if (minc == -2) {
- n = name;
- nlen = (namelen < 0 ? strlen(n) : namelen);
- } else
- n = scheme_get_proc_name((Scheme_Object *)name, &nlen, 1);
- if (!n) {
- n = "#<case-lambda-procedure>";
- nlen = strlen(n);
- }
- pos = scheme_sprintf(s, slen,
- "%s%s%t%s\n"
- " given: %d",
- prefix_msg1, prefix_msg2,
- n, (intptr_t)nlen,
- suffix_msg,
- xargc);
- } else if (!maxc)
- pos = scheme_sprintf(s, slen,
- "%s%s%t%s\n"
- " expected: 0\n"
- " given: %d",
- prefix_msg1, prefix_msg2,
- name, (intptr_t)namelen,
- suffix_msg,
- xargc);
- else if (maxc < 0)
- pos = scheme_sprintf(s, slen,
- "%s%s%t%s\n"
- " expected: at least %d\n"
- " given: %d",
- prefix_msg1, prefix_msg2,
- name, (intptr_t)namelen,
- suffix_msg,
- xminc, xargc);
- else if (minc == maxc)
- pos = scheme_sprintf(s, slen,
- "%s%s%t%s\n"
- " expected: %d\n"
- " given: %d",
- prefix_msg1, prefix_msg2,
- name, (intptr_t)namelen,
- suffix_msg,
- xminc, xargc);
- else
- pos = scheme_sprintf(s, slen,
- "%s%s%t%s\n"
- " expected: %d to %d\n"
- " given: %d",
- prefix_msg1, prefix_msg2,
- name, (intptr_t)namelen,
- suffix_msg,
- xminc, xmaxc, xargc);
- if (xargc && argv) {
- len -= (xargc * 4);
- len /= xargc;
- if ((xargc < 50) && (len >= 3)) {
- int i;
- for (i = (is_method ? 1 : 0); i < argc; i++) {
- intptr_t l;
- char *o;
- if (i == (is_method ? 1 : 0)) {
- strcpy(s + pos, "\n arguments...:\n ");
- pos += 20;
- } else {
- strcpy(s + pos, "\n ");
- pos += 4;
- }
- o = error_write_to_string_w_max(argv[i], len, &l);
- memcpy(s + pos, o, l);
- pos += l;
- }
- s[pos] = 0;
- }
- }
- *_len = pos;
- return s;
- }
- void scheme_wrong_count_m(const char *name, int minc, int maxc,
- int argc, Scheme_Object **argv, int is_method)
- /* minc == -1 => name is really a proc.
- minc == -2 => use generic "no matching clause" message */
- {
- char *s;
- intptr_t len;
- Scheme_Thread *p = scheme_current_thread;
- if (argv == p->tail_buffer) {
- /* See calls in scheme_do_eval: */
- scheme_realloc_tail_buffer(p);
- }
- /* minc = 1 -> name is really a case-lambda or native proc */
- if (minc == -1) {
- /* Extract arity, check for is_method in case-lambda, etc. */
- if (SAME_TYPE(SCHEME_TYPE((Scheme_Object *)name), scheme_closure_type)) {
- Scheme_Lambda *data;
- data = SCHEME_CLOSURE_CODE((Scheme_Object *)name);
- name = scheme_get_proc_name((Scheme_Object *)name, NULL, 1);
-
- minc = data->num_params;
- if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_REST) {
- minc -= 1;
- maxc = -1;
- } else
- maxc = minc;
- } else if (SAME_TYPE(SCHEME_TYPE((Scheme_Object *)name), scheme_case_closure_type)) {
- Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)name;
- if (cl->count) {
- Scheme_Lambda *data;
- data = (Scheme_Lambda *)SCHEME_CLOSURE_CODE(cl->array[0]);
- if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_IS_METHOD)
- is_method = 1;
- } else if (cl->name && SCHEME_BOXP(cl->name)) {
- /* See note in schpriv.h about the IS_METHOD hack */
- is_method = 1;
- }
- #ifdef MZ_USE_JIT
- } else if (SAME_TYPE(SCHEME_TYPE((Scheme_Object *)name), scheme_native_closure_type)) {
- Scheme_Object *pa;
- pa = scheme_get_native_arity((Scheme_Object *)name, -1);
- if (SCHEME_BOXP(pa)) {
- pa = SCHEME_BOX_VAL(pa);
- is_method = 1;
- }
- if (SCHEME_INTP(pa)) {
- minc = SCHEME_INT_VAL(pa);
- if (minc < 0) {
- minc = (-minc) - 1;
- maxc = -1;
- } else
- maxc = minc;
- name = scheme_get_proc_name((Scheme_Object *)name, NULL, 1);
- } else if (SCHEME_STRUCTP(pa)) {
- /* This happens when a non-case-lambda is not yet JITted.
- It's an arity-at-least record. */
- pa = ((Scheme_Structure *)pa)->slots[0];
- minc = SCHEME_INT_VAL(pa);
- maxc = -1;
- name = scheme_get_proc_name((Scheme_Object *)name, NULL, 1);
- } else {
- /* complex; use "no matching case" msg */
- }
- #endif
- }
- }
- /* Watch out for impossible is_method claims: */
- if (!argc || !minc)
- is_method = 0;
- if (maxc > SCHEME_MAX_ARGS)
- maxc = -1;
- s = make_arity_expect_string(name, -1, minc, maxc, argc, argv, &len, is_method, NULL);
- scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY, "%t", s, len);
- }
- void scheme_wrong_count(const char *name, int minc, int maxc, int argc,
- Scheme_Object **argv)
- {
- /* don't allocate here, in case rands == p->tail_buffer */
- scheme_wrong_count_m(name, minc, maxc, argc, argv, 0);
- }
- void scheme_case_lambda_wrong_count(const char *name,
- int argc, Scheme_Object **argv,
- int is_method,
- int count, ...)
- {
- char *s;
- intptr_t len;
- /* Watch out for impossible is_method claims: */
- if (!argc)
- is_method = 0;
- s = make_arity_expect_string(name, -1, -2, 0, argc, argv, &len, is_method, NULL);
- scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY, "%t", s, len);
- }
- char *scheme_make_arity_expect_string(const char *map_name,
- Scheme_Object *proc,
- int argc, Scheme_Object **argv,
- intptr_t *_slen)
- {
- const char *name;
- int namelen = -1;
- int mina, maxa;
- if (SCHEME_CHAPERONEP(proc)) {
- proc = SCHEME_CHAPERONE_VAL(proc);
- }
- if (SCHEME_PRIMP(proc)) {
- name = ((Scheme_Primitive_Proc *)proc)->name;
- mina = ((Scheme_Primitive_Proc *)proc)->mina;
- if (mina < 0) {
- /* set min1 to -2 to indicates cases */
- mina = -2;
- maxa = 0;
- } else {
- maxa = ((Scheme_Primitive_Proc *)proc)->mu.maxa;
- if (maxa > SCHEME_MAX_ARGS)
- maxa = -1;
- }
- } else if (SCHEME_CLSD_PRIMP(proc)) {
- name = ((Scheme_Closed_Primitive_Proc *)proc)->name;
- mina = ((Scheme_Closed_Primitive_Proc *)proc)->mina;
- maxa = ((Scheme_Closed_Primitive_Proc *)proc)->maxa;
- } else if (SAME_TYPE(SCHEME_TYPE(proc), scheme_case_closure_type)) {
- name = scheme_get_proc_name(proc, &namelen, 1);
- mina = -2;
- maxa = 0;
- #ifdef MZ_USE_JIT
- } else if (SAME_TYPE(SCHEME_TYPE((Scheme_Object *)proc), scheme_native_closure_type)) {
- Scheme_Object *pa;
- pa = scheme_get_native_arity((Scheme_Object *)proc, -1);
- if (SCHEME_BOXP(pa)) {
- pa = SCHEME_BOX_VAL(pa);
- }
- if (SCHEME_INTP(pa)) {
- mina = SCHEME_INT_VAL(pa);
- if (mina < 0) {
- mina = (-mina) - 1;
- maxa = -1;
- } else
- maxa = mina;
- } else if (SCHEME_STRUCTP(pa)) {
- /* This happens when a non-case-lambda is not yet JITted.
- It's an arity-at-least record. */
- pa = ((Scheme_Structure *)pa)->slots[0];
- mina = SCHEME_INT_VAL(pa);
- maxa = -1;
- } else {
- /* complex; use "no matching case" msg */
- mina = -2;
- maxa = 0;
- }
- name = scheme_get_proc_name((Scheme_Object *)proc, &namelen, 1);
- #endif
- } else if (SCHEME_CHAPERONE_STRUCTP(proc)) {
- name = (const char *)proc;
- mina = -1;
- maxa = 0;
- } else {
- Scheme_Lambda *data;
- data = (Scheme_Lambda *)SCHEME_CLOSURE_CODE(proc);
- mina = maxa = data->num_params;
- if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_REST) {
- --mina;
- maxa = -1;
- }
- name = scheme_get_proc_name(proc, &namelen, 1);
- }
- return make_arity_expect_string(name, namelen, mina, maxa, argc, argv, _slen, 0, map_name);
- }
- char *scheme_make_args_string(const char *s, int which, int argc, Scheme_Object **argv, intptr_t *_olen)
- {
- char *other;
- intptr_t len;
- GC_CAN_IGNORE char *isres = "arguments";
- other = init_buf(&len, NULL);
- if (argc < 0) {
- isres = "results";
- argc = -argc;
- }
- len /= (argc - (((which >= 0) && (argc > 1)) ? 1 : 0));
- if ((argc < 50) && (len >= 3)) {
- int i, pos;
- sprintf(other, "; %s%s were:", s, isres);
- pos = strlen(other);
- for (i = 0; i < argc; i++) {
- if (i != which) {
- intptr_t l;
- char *o;
- o = error_write_to_string_w_max(argv[i], len, &l);
- memcpy(other + pos, " ", 1);
- memcpy(other + pos + 1, o, l);
- pos += l + 1;
- }
- }
- other[pos] = 0;
- if (_olen)
- *_olen = pos;
- } else {
- sprintf(other, "; given %d arguments total", argc);
- if (_olen)
- *_olen = strlen(other);
- }
- return other;
- }
- char *scheme_make_arg_lines_string(const char *indent, int which, int argc, Scheme_Object **argv, intptr_t *_olen)
- {
- char *other;
- intptr_t len, plen;
- if (!argc || ((argc == 1) && (which == 0))) {
- other = " [none]";
- if (_olen)
- *_olen = strlen(other);
- return other;
- }
- other = init_buf(&len, NULL);
- plen = strlen(indent);
-
- len -= ((argc - 1) * (plen + 1));
- len /= (argc - (((which >= 0) && (argc > 1)) ? 1 : 0));
- if (len >= 3) {
- int i, pos;
- pos = 0;
- for (i = 0; i < argc; i++) {
- if (i != which) {
- intptr_t l;
- char *o;
-
- memcpy(other + pos, "\n", 1);
- pos++;
- memcpy(other + pos, indent, plen);
- pos += plen;
-
- o = error_write_to_string_w_max(argv[i], len, &l);
- memcpy(ot…
Large files files are truncated, but you can click here to view the full file