PageRenderTime 71ms CodeModel.GetById 22ms RepoModel.GetById 0ms app.codeStats 0ms

/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
Possible License(s): LGPL-3.0, GPL-3.0, BSD-3-Clause, CC-BY-SA-3.0
  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. #define mzVA_ARG(x, y) HIDE_FROM_XFORM(va_arg(x, y))
  13. #define TMP_CMARK_VALUE scheme_parameterization_key
  14. #ifndef INIT_SYSLOG_LEVEL
  15. # define INIT_SYSLOG_LEVEL 0
  16. #endif
  17. /* globals */
  18. SHARED_OK scheme_console_printf_t scheme_console_printf;
  19. scheme_console_printf_t scheme_get_console_printf() { return scheme_console_printf; }
  20. void scheme_set_console_printf(scheme_console_printf_t p) { scheme_console_printf = p; }
  21. SHARED_OK Scheme_Exit_Proc scheme_exit;
  22. void scheme_set_exit(Scheme_Exit_Proc p) { scheme_exit = p; }
  23. HOOK_SHARED_OK void (*scheme_console_output)(char *str, intptr_t len);
  24. void scheme_set_console_output(scheme_console_output_t p) { scheme_console_output = p; }
  25. SHARED_OK static Scheme_Object *init_syslog_level = scheme_make_integer(INIT_SYSLOG_LEVEL);
  26. SHARED_OK static Scheme_Object *init_stderr_level = scheme_make_integer(SCHEME_LOG_ERROR);
  27. SHARED_OK static Scheme_Object *init_stdout_level = scheme_make_integer(0);
  28. THREAD_LOCAL_DECL(static Scheme_Logger *scheme_main_logger);
  29. THREAD_LOCAL_DECL(static Scheme_Logger *scheme_gc_logger);
  30. THREAD_LOCAL_DECL(static Scheme_Logger *scheme_future_logger);
  31. THREAD_LOCAL_DECL(static Scheme_Logger *scheme_place_logger);
  32. /* readonly globals */
  33. ROSYM static Scheme_Object *none_symbol;
  34. ROSYM static Scheme_Object *fatal_symbol;
  35. ROSYM static Scheme_Object *error_symbol;
  36. ROSYM static Scheme_Object *warning_symbol;
  37. ROSYM static Scheme_Object *info_symbol;
  38. ROSYM static Scheme_Object *debug_symbol;
  39. ROSYM static Scheme_Object *posix_symbol;
  40. ROSYM static Scheme_Object *windows_symbol;
  41. ROSYM static Scheme_Object *gai_symbol;
  42. ROSYM static Scheme_Object *arity_property;
  43. ROSYM static Scheme_Object *def_err_val_proc;
  44. ROSYM static Scheme_Object *def_error_esc_proc;
  45. ROSYM static Scheme_Object *default_display_handler;
  46. ROSYM static Scheme_Object *emergency_display_handler;
  47. ROSYM static Scheme_Object *def_exe_yield_proc;
  48. READ_ONLY Scheme_Object *scheme_def_exit_proc;
  49. READ_ONLY Scheme_Object *scheme_raise_arity_error_proc;
  50. #ifdef MEMORY_COUNTING_ON
  51. intptr_t scheme_misc_count;
  52. #endif
  53. #ifdef MZ_USE_MZRT
  54. static mzrt_mutex *glib_log_queue_lock;
  55. typedef struct glib_log_queue_entry {
  56. const char *log_domain;
  57. int log_level;
  58. const char *message;
  59. struct glib_log_queue_entry *next;
  60. } glib_log_queue_entry;
  61. static glib_log_queue_entry *glib_log_queue;
  62. static void *glib_log_signal_handle;
  63. #endif
  64. /* locals */
  65. static Scheme_Object *error(int argc, Scheme_Object *argv[]);
  66. static Scheme_Object *raise_user_error(int argc, Scheme_Object *argv[]);
  67. static Scheme_Object *raise_type_error(int argc, Scheme_Object *argv[]);
  68. static Scheme_Object *raise_argument_error(int argc, Scheme_Object *argv[]);
  69. static Scheme_Object *raise_result_error(int argc, Scheme_Object *argv[]);
  70. static Scheme_Object *raise_mismatch_error(int argc, Scheme_Object *argv[]);
  71. static Scheme_Object *raise_arguments_error(int argc, Scheme_Object *argv[]);
  72. static Scheme_Object *raise_range_error(int argc, Scheme_Object *argv[]);
  73. static Scheme_Object *raise_arity_error(int argc, Scheme_Object *argv[]);
  74. static Scheme_Object *raise_arity_mask_error(int argc, Scheme_Object *argv[]);
  75. static Scheme_Object *raise_result_arity_error(int argc, Scheme_Object *argv[]);
  76. static Scheme_Object *error_escape_handler(int, Scheme_Object *[]);
  77. static Scheme_Object *error_display_handler(int, Scheme_Object *[]);
  78. static Scheme_Object *error_value_string_handler(int, Scheme_Object *[]);
  79. static Scheme_Object *exit_handler(int, Scheme_Object *[]);
  80. static Scheme_Object *exe_yield_handler(int, Scheme_Object *[]);
  81. static Scheme_Object *error_print_width(int, Scheme_Object *[]);
  82. static Scheme_Object *error_print_context_length(int, Scheme_Object *[]);
  83. static Scheme_Object *error_print_srcloc(int, Scheme_Object *[]);
  84. static MZ_NORETURN void def_error_escape_proc(int, Scheme_Object *[]);
  85. static Scheme_Object *def_error_display_proc(int, Scheme_Object *[]);
  86. static Scheme_Object *emergency_error_display_proc(int, Scheme_Object *[]);
  87. static Scheme_Object *def_error_value_string_proc(int, Scheme_Object *[]);
  88. static Scheme_Object *def_exit_handler_proc(int, Scheme_Object *[]);
  89. static Scheme_Object *default_yield_handler(int, Scheme_Object *[]);
  90. static Scheme_Object *srcloc_to_string(int argc, Scheme_Object **argv);
  91. static Scheme_Object *unquoted_printing_string(int argc, Scheme_Object **argv);
  92. static Scheme_Object *unquoted_printing_string_p(int argc, Scheme_Object **argv);
  93. static Scheme_Object *unquoted_printing_string_value(int argc, Scheme_Object **argv);
  94. static Scheme_Object *log_message(int argc, Scheme_Object *argv[]);
  95. static Scheme_Object *log_level_p(int argc, Scheme_Object *argv[]);
  96. static Scheme_Object *log_max_level(int argc, Scheme_Object *argv[]);
  97. static Scheme_Object *log_all_levels(int argc, Scheme_Object *argv[]);
  98. static Scheme_Object *log_level_evt(int argc, Scheme_Object *argv[]);
  99. static Scheme_Object *make_logger(int argc, Scheme_Object *argv[]);
  100. static Scheme_Object *logger_p(int argc, Scheme_Object *argv[]);
  101. static Scheme_Object *current_logger(int argc, Scheme_Object *argv[]);
  102. static Scheme_Object *logger_name(int argc, Scheme_Object *argv[]);
  103. static Scheme_Object *make_log_reader(int argc, Scheme_Object *argv[]);
  104. static Scheme_Object *log_reader_p(int argc, Scheme_Object *argv[]);
  105. static int log_reader_get(Scheme_Object *ch, Scheme_Schedule_Info *sinfo);
  106. static MZ_NORETURN void do_raise(Scheme_Object *arg, int need_debug, int barrier);
  107. static MZ_NORETURN void nested_exn_handler(void *old_exn, int argc, Scheme_Object *argv[]);
  108. static void update_want_level(Scheme_Logger *logger, Scheme_Object *name);
  109. static Scheme_Object *check_arity_property_value_ok(int argc, Scheme_Object *argv[]);
  110. static char *make_provided_list(Scheme_Object *o, int count, intptr_t *lenout);
  111. static char *init_buf(intptr_t *len, intptr_t *blen);
  112. void scheme_set_logging2(int syslog_level, int stderr_level, int stdout_level)
  113. {
  114. if (syslog_level > -1)
  115. init_syslog_level = scheme_make_integer(syslog_level);
  116. if (stderr_level > -1)
  117. init_stderr_level = scheme_make_integer(stderr_level);
  118. if (stdout_level > -1)
  119. init_stdout_level = scheme_make_integer(stdout_level);
  120. }
  121. void scheme_set_logging(int syslog_level, int stderr_level)
  122. {
  123. scheme_set_logging2(syslog_level, stderr_level, -1);
  124. }
  125. void scheme_set_logging2_spec(Scheme_Object *syslog_level, Scheme_Object *stderr_level, Scheme_Object *stdout_level)
  126. {
  127. /* A spec is (list* <int> <byte-string> .... <int>) */
  128. if (syslog_level) {
  129. REGISTER_SO(init_syslog_level);
  130. init_syslog_level = syslog_level;
  131. }
  132. if (stderr_level) {
  133. REGISTER_SO(init_stderr_level);
  134. init_stderr_level = stderr_level;
  135. }
  136. if (stdout_level) {
  137. REGISTER_SO(init_stdout_level);
  138. init_stdout_level = stdout_level;
  139. }
  140. }
  141. void scheme_set_logging_spec(Scheme_Object *syslog_level, Scheme_Object *stderr_level)
  142. {
  143. scheme_set_logging2_spec(syslog_level, stderr_level, NULL);
  144. }
  145. void scheme_init_logging_once(void)
  146. {
  147. /* Convert specs to use symbols */
  148. int j;
  149. Scheme_Object *l, *s;
  150. for (j = 0; j < 3; j++) {
  151. switch (j) {
  152. case 0: l = init_syslog_level; break;
  153. case 1: l = init_stderr_level; break;
  154. default: l = init_stdout_level; break;
  155. }
  156. if (l) {
  157. while (!SCHEME_INTP(l)) {
  158. l = SCHEME_CDR(l);
  159. s = scheme_intern_exact_symbol(SCHEME_BYTE_STR_VAL(SCHEME_CAR(l)),
  160. SCHEME_BYTE_STRLEN_VAL(SCHEME_CAR(l)));
  161. SCHEME_CAR(l) = s;
  162. l = SCHEME_CDR(l);
  163. }
  164. }
  165. }
  166. }
  167. typedef struct {
  168. int args;
  169. Scheme_Object *type;
  170. Scheme_Object **names;
  171. int count;
  172. Scheme_Object *exptime;
  173. int super_pos;
  174. } exn_rec;
  175. #define _MZEXN_TABLE
  176. #include "schexn.h"
  177. #undef _MZEXN_TABLE
  178. static void default_printf(char *msg, ...)
  179. {
  180. GC_CAN_IGNORE va_list args;
  181. HIDE_FROM_XFORM(va_start(args, msg));
  182. vfprintf(stderr, msg, args);
  183. HIDE_FROM_XFORM(va_end(args));
  184. fflush(stderr);
  185. }
  186. static void default_output(char *s, intptr_t len)
  187. {
  188. fwrite(s, len, 1, stderr);
  189. fflush(stderr);
  190. }
  191. intptr_t scheme_errno() {
  192. #ifdef WINDOWS_FILE_HANDLES
  193. return GetLastError();
  194. #else
  195. return errno;
  196. #endif
  197. }
  198. Scheme_Config *scheme_init_error_escape_proc(Scheme_Config *config)
  199. {
  200. if (!def_error_esc_proc) {
  201. REGISTER_SO(def_error_esc_proc);
  202. def_error_esc_proc =
  203. scheme_make_prim_w_arity((Scheme_Prim *)def_error_escape_proc,
  204. "default-error-escape-handler",
  205. 0, 0);
  206. }
  207. if (config)
  208. return scheme_extend_config(config, MZCONFIG_ERROR_ESCAPE_HANDLER, def_error_esc_proc);
  209. else {
  210. scheme_set_root_param(MZCONFIG_ERROR_ESCAPE_HANDLER, def_error_esc_proc);
  211. return NULL;
  212. }
  213. }
  214. /*
  215. Recognized by scheme_[v]sprintf:
  216. %c = unicode char
  217. %d = int
  218. %gd = long int
  219. %gx = long int
  220. %ld = intptr_t
  221. %Id = intptr_t (for MSVC)
  222. %I64d = intptr_t (for MingGW)
  223. %lx = intptr_t
  224. %Ix = intptr_t (for MSVC)
  225. %I64x = intptr_t (for MingGW)
  226. %o = int, octal
  227. %f = double
  228. %% = percent
  229. %s = string
  230. %5 = mzchar string
  231. %S = Scheme symbol
  232. %t = string with inptr_t size
  233. %u = mzchar string with intptr_t size
  234. %T = Scheme string
  235. %q = truncated-to-256 string
  236. %Q = truncated-to-256 Scheme string
  237. %V = scheme_value
  238. %@ = list of scheme_value to write splice
  239. %D = scheme value to display
  240. %W = scheme value to write
  241. %_ = skip pointer
  242. %- = skip int
  243. %L = line number as intptr_t, -1 means no line
  244. %R = get error number and string from rktio
  245. %e = error number for strerror()
  246. %E = error number for platform-specific error string
  247. %Z = potential platform-specific error number; additional char*
  248. is either NULL or a specific error message
  249. %N = boolean then error number like %E (if boolean is 0)
  250. or error number for scheme_hostname_error()
  251. %m = boolean then error number like %e, which
  252. is used only if the boolean is 1
  253. %M = boolean then error number like %E, which
  254. is used only if the boolean is 1
  255. */
  256. static intptr_t sch_vsprintf(char *s, intptr_t maxlen, const char *msg, va_list args, char **_s,
  257. Scheme_Object **_errno_val, int *_unsupported)
  258. /* NULL for s means allocate the buffer here (and return in (_s), but this function
  259. doesn't allocate before extracting arguments from the stack. */
  260. {
  261. intptr_t i, j;
  262. char buf[100];
  263. /* Since we might malloc, move all pointers into a local array for
  264. the sake of precise GC. We have to do numbers, too, for
  265. consistency. */
  266. int pp = 0, ip = 0, dp = 0;
  267. void *ptrs[25];
  268. intptr_t ints[25];
  269. double dbls[25];
  270. for (j = 0; msg[j]; j++) {
  271. if (msg[j] == '%') {
  272. int type;
  273. j++;
  274. type = msg[j];
  275. switch (type) {
  276. case 'c':
  277. ints[ip++] = mzVA_ARG(args, int);
  278. break;
  279. case 'd':
  280. case 'o':
  281. case '-':
  282. ints[ip++] = mzVA_ARG(args, int);
  283. break;
  284. case 'g':
  285. ints[ip++] = mzVA_ARG(args, long);
  286. break;
  287. case 'l':
  288. case 'I':
  289. ints[ip++] = mzVA_ARG(args, intptr_t);
  290. break;
  291. case 'f':
  292. dbls[dp++] = mzVA_ARG(args, double);
  293. break;
  294. case 'L':
  295. ints[ip++] = mzVA_ARG(args, intptr_t);
  296. break;
  297. case 'e':
  298. case 'E':
  299. ints[ip++] = mzVA_ARG(args, int);
  300. break;
  301. case 'N':
  302. case 'm':
  303. case 'M':
  304. ints[ip++] = mzVA_ARG(args, int);
  305. ints[ip++] = mzVA_ARG(args, int);
  306. break;
  307. case 'Z':
  308. ints[ip++] = mzVA_ARG(args, int);
  309. ptrs[pp++] = mzVA_ARG(args, char*);
  310. break;
  311. case 'S':
  312. case 'V':
  313. case '@':
  314. case 'D':
  315. case 'W':
  316. case 'T':
  317. case 'Q':
  318. case '_':
  319. ptrs[pp++] = mzVA_ARG(args, Scheme_Object*);
  320. break;
  321. default:
  322. ptrs[pp++] = mzVA_ARG(args, char*);
  323. if ((type == 't') || (type == 'u')) {
  324. ints[ip++] = mzVA_ARG(args, intptr_t);
  325. }
  326. }
  327. }
  328. }
  329. pp = 0;
  330. ip = 0;
  331. dp = 0;
  332. if (!s) {
  333. s = init_buf(NULL, &maxlen);
  334. *_s = s;
  335. }
  336. --maxlen;
  337. i = j = 0;
  338. while ((i < maxlen) && msg[j]) {
  339. if (msg[j] == '%') {
  340. int type;
  341. j++;
  342. type = msg[j++];
  343. if (type == '%')
  344. s[i++] = '%';
  345. else {
  346. const char *t;
  347. intptr_t tlen;
  348. int dots = 0;
  349. switch (type) {
  350. case 'c':
  351. {
  352. int c;
  353. c = ints[ip++];
  354. if (c < 128) {
  355. buf[0] = c;
  356. tlen = 1;
  357. } else {
  358. mzchar mc;
  359. mc = c;
  360. tlen = scheme_utf8_encode_all(&mc, 1, (unsigned char *)buf);
  361. }
  362. t = buf;
  363. }
  364. break;
  365. case 'd':
  366. {
  367. int d;
  368. d = ints[ip++];
  369. sprintf(buf, "%d", d);
  370. t = buf;
  371. tlen = strlen(t);
  372. }
  373. break;
  374. case '-':
  375. {
  376. ip++;
  377. t = "";
  378. tlen = 0;
  379. }
  380. break;
  381. case 'o':
  382. {
  383. int d;
  384. d = ints[ip++];
  385. sprintf(buf, "%o", d);
  386. t = buf;
  387. tlen = strlen(t);
  388. }
  389. break;
  390. case 'I':
  391. case 'l':
  392. case 'g':
  393. {
  394. intptr_t d;
  395. int as_hex;
  396. if ((type == 'I') && (msg[j] == '6') && (msg[j+1] == '4'))
  397. j++;
  398. as_hex = (msg[j] == 'x');
  399. j++;
  400. d = ints[ip++];
  401. if (as_hex)
  402. sprintf(buf, "%" PRIxPTR, d);
  403. else
  404. sprintf(buf, "%" PRIdPTR, d);
  405. t = buf;
  406. tlen = strlen(t);
  407. }
  408. break;
  409. case 'f':
  410. {
  411. double f;
  412. f = dbls[dp++];
  413. sprintf(buf, "%f", f);
  414. t = buf;
  415. tlen = strlen(t);
  416. }
  417. break;
  418. case 'L':
  419. {
  420. intptr_t d;
  421. d = ints[ip++];
  422. if (d >= 0) {
  423. sprintf(buf, "%" PRIdPTR ":", d);
  424. t = buf;
  425. tlen = strlen(t);
  426. } else {
  427. t = ":";
  428. tlen = 1;
  429. }
  430. }
  431. break;
  432. case 'R':
  433. {
  434. intptr_t errid;
  435. intptr_t errkind;
  436. const char *es, *errkind_str;
  437. intptr_t elen;
  438. errkind = rktio_get_last_error_kind(scheme_rktio);
  439. errid = rktio_get_last_error(scheme_rktio);
  440. switch (errkind) {
  441. case RKTIO_ERROR_KIND_WINDOWS:
  442. errkind_str = "errid";
  443. break;
  444. case RKTIO_ERROR_KIND_POSIX:
  445. errkind_str = "errno";
  446. break;
  447. case RKTIO_ERROR_KIND_GAI:
  448. errkind_str = "gai_err";
  449. break;
  450. default:
  451. errkind_str = "rktio_err";
  452. break;
  453. }
  454. es = rktio_get_error_string(scheme_rktio, errkind, errid);
  455. sprintf(buf, "; %s=%" PRIdPTR "", errkind_str, errid);
  456. if (es) elen = strlen(es); else elen = 0;
  457. tlen = strlen(buf);
  458. t = (const char *)scheme_malloc_atomic(tlen+elen+1);
  459. memcpy((char *)t, es, elen);
  460. memcpy((char *)t+elen, buf, tlen+1);
  461. tlen += elen;
  462. if (_errno_val) {
  463. Scheme_Object *err_kind;
  464. switch (errkind) {
  465. case RKTIO_ERROR_KIND_WINDOWS:
  466. err_kind = windows_symbol;
  467. break;
  468. case RKTIO_ERROR_KIND_POSIX:
  469. err_kind = posix_symbol;
  470. break;
  471. case RKTIO_ERROR_KIND_GAI:
  472. err_kind = gai_symbol;
  473. break;
  474. default:
  475. err_kind = NULL;
  476. }
  477. if (err_kind) {
  478. err_kind = scheme_make_pair(scheme_make_integer_value(errid), err_kind);
  479. *_errno_val = err_kind;
  480. }
  481. }
  482. if (_unsupported
  483. && (errid == RKTIO_ERROR_UNSUPPORTED)
  484. && (errkind == RKTIO_ERROR_KIND_RACKET))
  485. *_unsupported = 1;
  486. }
  487. break;
  488. case 'e':
  489. case 'm':
  490. case 'E':
  491. case 'M':
  492. case 'Z':
  493. case 'N':
  494. {
  495. int en, he, none = 0;
  496. char *es;
  497. const char *errkind_str = NULL;
  498. Scheme_Object *err_kind = NULL;
  499. if (type == 'm') {
  500. none = !ints[ip++];
  501. type = 'e';
  502. he = 0;
  503. } else if (type == 'M') {
  504. none = !ints[ip++];
  505. type = 'E';
  506. he = 0;
  507. } else if (type == 'N') {
  508. he = ints[ip++];
  509. type = 'E';
  510. } else
  511. he = 0;
  512. en = ints[ip++];
  513. if (type == 'Z')
  514. es = ptrs[pp++];
  515. else
  516. es = NULL;
  517. if (he) {
  518. es = (char *)scheme_hostname_error(en);
  519. err_kind = gai_symbol;
  520. errkind_str = "gai_err";
  521. }
  522. if ((en || es) && !none) {
  523. #ifdef NO_STRERROR_AVAILABLE
  524. if (!es)
  525. es = "Unknown error";
  526. err_kind = posix_symbol;
  527. #else
  528. # ifdef DOS_FILE_SYSTEM
  529. wchar_t mbuf[256];
  530. int len;
  531. if ((type != 'e') && !es) {
  532. if ((len = FormatMessageW((FORMAT_MESSAGE_FROM_SYSTEM
  533. | FORMAT_MESSAGE_IGNORE_INSERTS),
  534. NULL,
  535. en, MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
  536. mbuf, 255, NULL))) {
  537. int i;
  538. i = scheme_utf8_encode((const unsigned int *)mbuf, 0, len, NULL, 0, 1);
  539. es = (char *)scheme_malloc_atomic(i + 1);
  540. (void)scheme_utf8_encode((const unsigned int *)mbuf, 0, len, es, 0, 1);
  541. es[i] = 0;
  542. /* Remove newlines: */
  543. for (i = strlen(es) - 1; i > 0; i--) {
  544. if (isspace(es[i]))
  545. es[i] = 0;
  546. else
  547. break;
  548. }
  549. err_kind = windows_symbol;
  550. errkind_str = "win_err";
  551. }
  552. }
  553. # endif
  554. if (!es) {
  555. es = strerror(en);
  556. err_kind = posix_symbol;
  557. errkind_str = "errno";
  558. }
  559. #endif
  560. tlen = strlen(es) + 24;
  561. t = (const char *)scheme_malloc_atomic(tlen);
  562. MZ_ASSERT(errkind_str);
  563. sprintf((char *)t, "%s; %s=%d", es, errkind_str, en);
  564. tlen = strlen(t);
  565. if (_errno_val) {
  566. err_kind = scheme_make_pair(scheme_make_integer_value(en), err_kind);
  567. *_errno_val = err_kind;
  568. }
  569. } else {
  570. if (none) {
  571. t = "";
  572. tlen = 0;
  573. } else {
  574. t = "errno=?";
  575. tlen = 7;
  576. }
  577. }
  578. }
  579. break;
  580. case 'S':
  581. {
  582. Scheme_Object *sym;
  583. sym = (Scheme_Object *)ptrs[pp++];
  584. t = scheme_symbol_name_and_size(sym, (uintptr_t *)&tlen, 0);
  585. }
  586. break;
  587. case 'V':
  588. {
  589. Scheme_Object *o;
  590. o = (Scheme_Object *)ptrs[pp++];
  591. t = scheme_make_provided_string(o, 1, &tlen);
  592. }
  593. break;
  594. case '@':
  595. {
  596. Scheme_Object *o;
  597. o = (Scheme_Object *)ptrs[pp++];
  598. t = make_provided_list(o, 1, &tlen);
  599. }
  600. break;
  601. case 'D':
  602. {
  603. Scheme_Object *o;
  604. intptr_t dlen;
  605. o = (Scheme_Object *)ptrs[pp++];
  606. t = scheme_display_to_string(o, &dlen);
  607. tlen = dlen;
  608. }
  609. break;
  610. case 'W':
  611. {
  612. Scheme_Object *o;
  613. intptr_t dlen;
  614. o = (Scheme_Object *)ptrs[pp++];
  615. t = scheme_write_to_string(o, &dlen);
  616. tlen = dlen;
  617. }
  618. break;
  619. case '_':
  620. {
  621. pp++;
  622. t = "";
  623. tlen = 0;
  624. }
  625. break;
  626. case 'T':
  627. case 'Q':
  628. {
  629. Scheme_Object *str;
  630. str = (Scheme_Object *)ptrs[pp++];
  631. if (SCHEME_CHAR_STRINGP(str))
  632. str = scheme_char_string_to_byte_string(str);
  633. t = SCHEME_BYTE_STR_VAL(str);
  634. tlen = SCHEME_BYTE_STRLEN_VAL(str);
  635. }
  636. break;
  637. case 'u':
  638. case '5':
  639. {
  640. mzchar *u;
  641. intptr_t ltlen;
  642. u = (mzchar *)ptrs[pp++];
  643. if (type == 'u') {
  644. tlen = ints[ip++];
  645. if (tlen < 0)
  646. tlen = scheme_char_strlen(u);
  647. } else {
  648. tlen = scheme_char_strlen(u);
  649. }
  650. t = scheme_utf8_encode_to_buffer_len(u, tlen, NULL, 0, &ltlen);
  651. tlen = ltlen;
  652. }
  653. break;
  654. default:
  655. {
  656. t = (char *)ptrs[pp++];
  657. if (type == 't') {
  658. tlen = ints[ip++];
  659. if (tlen < 0)
  660. tlen = strlen(t);
  661. } else {
  662. tlen = strlen(t);
  663. }
  664. }
  665. break;
  666. }
  667. if ((type == 'q') || (type == 'Q')) {
  668. if (tlen > 256) {
  669. tlen = 250;
  670. dots = 1;
  671. }
  672. }
  673. while (tlen && i < maxlen) {
  674. s[i++] = *t;
  675. t = t XFORM_OK_PLUS 1;
  676. tlen--;
  677. }
  678. if (dots) {
  679. /* FIXME: avoiding truncating in the middle of a UTF-8 encoding */
  680. if (i < maxlen - 3) {
  681. s[i++] = '.';
  682. s[i++] = '.';
  683. s[i++] = '.';
  684. }
  685. }
  686. }
  687. } else {
  688. s[i++] = msg[j++];
  689. }
  690. }
  691. s[i] = 0;
  692. return i;
  693. }
  694. intptr_t scheme_sprintf(char *s, intptr_t maxlen, const char *msg, ...)
  695. {
  696. intptr_t len;
  697. GC_CAN_IGNORE va_list args;
  698. HIDE_FROM_XFORM(va_start(args, msg));
  699. len = sch_vsprintf(s, maxlen, msg, args, NULL, NULL, NULL);
  700. HIDE_FROM_XFORM(va_end(args));
  701. return len;
  702. }
  703. int scheme_last_error_is_racket(int errid)
  704. {
  705. return ((rktio_get_last_error_kind(scheme_rktio) == RKTIO_ERROR_KIND_RACKET)
  706. && (rktio_get_last_error(scheme_rktio) == errid));
  707. }
  708. #define ESCAPING_NONCM_PRIM(name, func, a1, a2, env) \
  709. p = scheme_make_noncm_prim(func, name, a1, a2); \
  710. SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_ALWAYS_ESCAPES); \
  711. scheme_addto_prim_instance(name, p, env);
  712. void scheme_init_error(Scheme_Startup_Env *env)
  713. {
  714. Scheme_Object *p;
  715. if (!scheme_console_printf)
  716. scheme_console_printf = default_printf;
  717. if (!scheme_console_output)
  718. scheme_console_output = default_output;
  719. REGISTER_SO(scheme_raise_arity_error_proc);
  720. /* errors */
  721. ESCAPING_NONCM_PRIM("error", error, 1, -1, env);
  722. ESCAPING_NONCM_PRIM("raise-user-error", raise_user_error, 1, -1, env);
  723. ESCAPING_NONCM_PRIM("raise-type-error", raise_type_error, 3, -1, env);
  724. ESCAPING_NONCM_PRIM("raise-argument-error", raise_argument_error, 3, -1, env);
  725. ESCAPING_NONCM_PRIM("raise-result-error", raise_result_error, 3, -1, env);
  726. ESCAPING_NONCM_PRIM("raise-arguments-error", raise_arguments_error, 2, -1, env);
  727. ESCAPING_NONCM_PRIM("raise-mismatch-error", raise_mismatch_error, 3, -1, env);
  728. ESCAPING_NONCM_PRIM("raise-range-error", raise_range_error, 7, 8, env);
  729. scheme_raise_arity_error_proc = scheme_make_noncm_prim(raise_arity_error, "raise-arity-error", 2, -1);
  730. scheme_addto_prim_instance("raise-arity-error", scheme_raise_arity_error_proc, env);
  731. ESCAPING_NONCM_PRIM("raise-arity-mask-error", raise_arity_mask_error, 2, -1, env);
  732. ESCAPING_NONCM_PRIM("raise-result-arity-error", raise_result_arity_error, 3, -1, env);
  733. ADD_PARAMETER("error-display-handler", error_display_handler, MZCONFIG_ERROR_DISPLAY_HANDLER, env);
  734. ADD_PARAMETER("error-value->string-handler", error_value_string_handler, MZCONFIG_ERROR_PRINT_VALUE_HANDLER, env);
  735. ADD_PARAMETER("error-escape-handler", error_escape_handler, MZCONFIG_ERROR_ESCAPE_HANDLER, env);
  736. ADD_PARAMETER("exit-handler", exit_handler, MZCONFIG_EXIT_HANDLER, env);
  737. ADD_PARAMETER("executable-yield-handler", exe_yield_handler, MZCONFIG_EXE_YIELD_HANDLER, env);
  738. ADD_PARAMETER("error-print-width", error_print_width, MZCONFIG_ERROR_PRINT_WIDTH, env);
  739. ADD_PARAMETER("error-print-context-length", error_print_context_length, MZCONFIG_ERROR_PRINT_CONTEXT_LENGTH, env);
  740. ADD_PARAMETER("error-print-source-location", error_print_srcloc, MZCONFIG_ERROR_PRINT_SRCLOC, env);
  741. ADD_NONCM_PRIM("exit", scheme_do_exit, 0, 1, env);
  742. /* logging */
  743. ADD_NONCM_PRIM("log-level?", log_level_p, 2, 3, env);
  744. ADD_NONCM_PRIM("log-max-level", log_max_level, 1, 2, env);
  745. ADD_NONCM_PRIM("log-all-levels", log_all_levels, 1, 1, env);
  746. ADD_NONCM_PRIM("log-level-evt", log_level_evt, 1, 1, env);
  747. ADD_NONCM_PRIM("make-logger", make_logger, 0, -1, env);
  748. ADD_NONCM_PRIM("make-log-receiver", make_log_reader, 2, -1, env);
  749. ADD_PRIM_W_ARITY("log-message", log_message, 3, 6, env);
  750. ADD_FOLDING_PRIM("logger?", logger_p, 1, 1, 1, env);
  751. ADD_FOLDING_PRIM("logger-name", logger_name, 1, 1, 1, env);
  752. ADD_FOLDING_PRIM("log-receiver?", log_reader_p, 1, 1, 1, env);
  753. ADD_PARAMETER("current-logger", current_logger, MZCONFIG_LOGGER, env);
  754. ADD_NONCM_PRIM("srcloc->string", srcloc_to_string, 1, 1, env);
  755. ADD_NONCM_PRIM("unquoted-printing-string", unquoted_printing_string, 1, 1, env);
  756. ADD_FOLDING_PRIM("unquoted-printing-string?", unquoted_printing_string_p, 1, 1, 1, env);
  757. ADD_IMMED_PRIM("unquoted-printing-string-value", unquoted_printing_string_value, 1, 1, env);
  758. REGISTER_SO(scheme_def_exit_proc);
  759. REGISTER_SO(default_display_handler);
  760. REGISTER_SO(emergency_display_handler);
  761. scheme_def_exit_proc = scheme_make_prim_w_arity(def_exit_handler_proc, "default-exit-handler", 1, 1);
  762. default_display_handler = scheme_make_prim_w_arity(def_error_display_proc, "default-error-display-handler", 2, 2);
  763. emergency_display_handler = scheme_make_prim_w_arity(emergency_error_display_proc, "emergency-error-display-handler", 2, 2);
  764. REGISTER_SO(def_err_val_proc);
  765. def_err_val_proc = scheme_make_prim_w_arity(def_error_value_string_proc, "default-error-value->string-handler", 2, 2);
  766. REGISTER_SO(none_symbol);
  767. REGISTER_SO(fatal_symbol);
  768. REGISTER_SO(error_symbol);
  769. REGISTER_SO(warning_symbol);
  770. REGISTER_SO(info_symbol);
  771. REGISTER_SO(debug_symbol);
  772. none_symbol = scheme_intern_symbol("none");
  773. fatal_symbol = scheme_intern_symbol("fatal");
  774. error_symbol = scheme_intern_symbol("error");
  775. warning_symbol = scheme_intern_symbol("warning");
  776. info_symbol = scheme_intern_symbol("info");
  777. debug_symbol = scheme_intern_symbol("debug");
  778. REGISTER_SO(posix_symbol);
  779. REGISTER_SO(windows_symbol);
  780. REGISTER_SO(gai_symbol);
  781. posix_symbol = scheme_intern_symbol("posix");
  782. windows_symbol = scheme_intern_symbol("windows");
  783. gai_symbol = scheme_intern_symbol("gai");
  784. REGISTER_SO(arity_property);
  785. {
  786. Scheme_Object *guard;
  787. guard = scheme_make_prim_w_arity(check_arity_property_value_ok, "guard-for-prop:arity-string", 2, 2);
  788. arity_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("arity-string"), guard);
  789. }
  790. scheme_addto_prim_instance("prop:arity-string", arity_property, env);
  791. REGISTER_SO(def_exe_yield_proc);
  792. def_exe_yield_proc = scheme_make_prim_w_arity(default_yield_handler,
  793. "default-executable-yield-handler",
  794. 1, 1);
  795. }
  796. void scheme_init_logger_wait()
  797. {
  798. scheme_add_evt(scheme_log_reader_type, (Scheme_Ready_Fun)log_reader_get, NULL, NULL, 1);
  799. }
  800. void scheme_init_logger()
  801. {
  802. REGISTER_SO(scheme_main_logger);
  803. scheme_main_logger = scheme_make_logger(NULL, NULL);
  804. scheme_main_logger->syslog_level = init_syslog_level;
  805. scheme_main_logger->stderr_level = init_stderr_level;
  806. scheme_main_logger->stdout_level = init_stdout_level;
  807. REGISTER_SO(scheme_gc_logger);
  808. scheme_gc_logger = scheme_make_logger(scheme_main_logger, scheme_intern_symbol("GC"));
  809. REGISTER_SO(scheme_future_logger);
  810. scheme_future_logger = scheme_make_logger(scheme_main_logger, scheme_intern_symbol("future"));
  811. REGISTER_SO(scheme_place_logger);
  812. scheme_place_logger = scheme_make_logger(scheme_main_logger, scheme_intern_symbol("place"));
  813. }
  814. Scheme_Logger *scheme_get_main_logger() {
  815. return scheme_main_logger;
  816. }
  817. Scheme_Logger *scheme_get_gc_logger() {
  818. return scheme_gc_logger;
  819. }
  820. Scheme_Logger *scheme_get_future_logger() {
  821. return scheme_future_logger;
  822. }
  823. Scheme_Logger *scheme_get_place_logger() {
  824. return scheme_place_logger;
  825. }
  826. void scheme_init_error_config(void)
  827. {
  828. scheme_set_root_param(MZCONFIG_EXIT_HANDLER, scheme_def_exit_proc);
  829. scheme_set_root_param(MZCONFIG_ERROR_DISPLAY_HANDLER, default_display_handler);
  830. scheme_set_root_param(MZCONFIG_ERROR_PRINT_VALUE_HANDLER, def_err_val_proc);
  831. scheme_set_root_param(MZCONFIG_EXE_YIELD_HANDLER, def_exe_yield_proc);
  832. }
  833. void scheme_init_logger_config() {
  834. scheme_set_root_param(MZCONFIG_LOGGER, (Scheme_Object *)scheme_main_logger);
  835. }
  836. static MZ_NORETURN void
  837. call_error(char *buffer, int len, Scheme_Object *exn)
  838. {
  839. if (scheme_current_thread->constant_folding) {
  840. if (scheme_current_thread->constant_folding != (Optimize_Info *)scheme_false)
  841. scheme_log(scheme_optimize_info_logger(scheme_current_thread->constant_folding),
  842. SCHEME_LOG_WARNING,
  843. 0,
  844. "constant-fold attempt failed%s: %s",
  845. scheme_optimize_info_context(scheme_current_thread->constant_folding),
  846. buffer);
  847. if (SCHEME_CHAPERONE_STRUCTP(exn)
  848. && scheme_is_struct_instance(exn_table[MZEXN_BREAK].type, exn)) {
  849. /* remember to re-raise exception */
  850. scheme_current_thread->reading_delayed = exn;
  851. }
  852. scheme_longjmp(scheme_error_buf, 1);
  853. } else if (scheme_current_thread->reading_delayed) {
  854. scheme_current_thread->reading_delayed = exn;
  855. scheme_longjmp(scheme_error_buf, 1);
  856. } else {
  857. mz_jmp_buf savebuf;
  858. Scheme_Object *p[2], *display_handler, *escape_handler, *v;
  859. Scheme_Config *config, *orig_config;
  860. Scheme_Cont_Frame_Data cframe, cframe2;
  861. /* For last resort: */
  862. memcpy((void *)&savebuf, &scheme_error_buf, sizeof(mz_jmp_buf));
  863. orig_config = scheme_current_config();
  864. display_handler = scheme_get_param(orig_config, MZCONFIG_ERROR_DISPLAY_HANDLER);
  865. escape_handler = scheme_get_param(orig_config, MZCONFIG_ERROR_ESCAPE_HANDLER);
  866. v = scheme_make_byte_string_without_copying("error display handler");
  867. v = scheme_make_closed_prim_w_arity((Scheme_Closed_Prim *)nested_exn_handler,
  868. scheme_make_pair(v, exn),
  869. "nested-exception-handler",
  870. 1, 1);
  871. config = orig_config;
  872. if (SAME_OBJ(display_handler, default_display_handler))
  873. config = scheme_extend_config(config,
  874. MZCONFIG_ERROR_DISPLAY_HANDLER,
  875. emergency_display_handler);
  876. else
  877. config = scheme_extend_config(config,
  878. MZCONFIG_ERROR_DISPLAY_HANDLER,
  879. default_display_handler);
  880. scheme_push_continuation_frame(&cframe);
  881. scheme_install_config(config);
  882. scheme_set_cont_mark(scheme_exn_handler_key, v);
  883. scheme_push_break_enable(&cframe2, 0, 0);
  884. if (SCHEME_CHAPERONE_STRUCTP(exn)
  885. && (scheme_is_struct_instance(exn_table[MZEXN_BREAK_HANG_UP].type, exn))) {
  886. /* skip printout */
  887. } else {
  888. p[0] = scheme_make_immutable_sized_utf8_string(buffer, len);
  889. p[1] = exn;
  890. scheme_apply_multi(display_handler, 2, p);
  891. }
  892. if (SCHEME_CHAPERONE_STRUCTP(exn)
  893. && (scheme_is_struct_instance(exn_table[MZEXN_BREAK_HANG_UP].type, exn)
  894. || scheme_is_struct_instance(exn_table[MZEXN_BREAK_TERMINATE].type, exn))) {
  895. /* Default uncaught exception handler exits on `exn:break:hang-up'
  896. or `exn:break:terminate'. */
  897. p[0] = scheme_make_integer(1);
  898. scheme_do_exit(1, p);
  899. /* Fall through to regular escape if the exit handler doesn't exit/escape. */
  900. }
  901. v = scheme_make_byte_string_without_copying("error escape handler");
  902. v = scheme_make_closed_prim_w_arity((Scheme_Closed_Prim *)nested_exn_handler,
  903. scheme_make_pair(v, exn),
  904. "nested-exception-handler",
  905. 1, 1);
  906. config = scheme_extend_config(config,
  907. MZCONFIG_ERROR_DISPLAY_HANDLER,
  908. default_display_handler);
  909. config = scheme_extend_config(config,
  910. MZCONFIG_ERROR_ESCAPE_HANDLER,
  911. def_error_esc_proc);
  912. scheme_pop_break_enable(&cframe2, 0);
  913. scheme_pop_continuation_frame(&cframe);
  914. scheme_push_continuation_frame(&cframe);
  915. scheme_set_cont_mark(scheme_exn_handler_key, v);
  916. scheme_install_config(config);
  917. scheme_push_break_enable(&cframe2, 0, 0);
  918. /* Typically jumps out of here */
  919. scheme_apply_multi(escape_handler, 0, NULL);
  920. scheme_pop_break_enable(&cframe2, 0);
  921. scheme_pop_continuation_frame(&cframe);
  922. /* Didn't escape, so fall back to the default escaper: */
  923. def_error_escape_proc(0, NULL);
  924. }
  925. }
  926. intptr_t scheme_get_print_width(void)
  927. {
  928. intptr_t print_width;
  929. Scheme_Object *w;
  930. w = scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PRINT_WIDTH);
  931. if (SCHEME_INTP(w))
  932. print_width = SCHEME_INT_VAL(w);
  933. else if (SCHEME_BIGNUMP(w))
  934. print_width = 0x7FFFFFFF;
  935. else
  936. print_width = 10000;
  937. return print_width;
  938. }
  939. static char *init_buf(intptr_t *len, intptr_t *_size)
  940. {
  941. uintptr_t local_max_symbol_length;
  942. intptr_t print_width;
  943. intptr_t size;
  944. local_max_symbol_length = scheme_get_max_symbol_length();
  945. print_width = scheme_get_print_width();
  946. size = (3 * local_max_symbol_length + 500 + 2 * print_width);
  947. /* out parameters */
  948. if (len)
  949. *len = print_width;
  950. if (_size)
  951. *_size = size;
  952. return (char *)scheme_malloc_atomic(size);
  953. }
  954. void
  955. scheme_signal_error (const char *msg, ...)
  956. {
  957. GC_CAN_IGNORE va_list args;
  958. char *buffer;
  959. intptr_t len;
  960. HIDE_FROM_XFORM(va_start(args, msg));
  961. len = sch_vsprintf(NULL, 0, msg, args, &buffer, NULL, NULL);
  962. HIDE_FROM_XFORM(va_end(args));
  963. buffer[len] = 0;
  964. if (scheme_starting_up) {
  965. buffer[len++] = '\n';
  966. buffer[len] = 0;
  967. scheme_console_output(buffer, len);
  968. exit(0);
  969. }
  970. scheme_raise_exn(MZEXN_FAIL, "%t", buffer, len);
  971. }
  972. void scheme_warning(char *msg, ...)
  973. {
  974. GC_CAN_IGNORE va_list args;
  975. char *buffer;
  976. intptr_t len;
  977. HIDE_FROM_XFORM(va_start(args, msg));
  978. len = sch_vsprintf(NULL, 0, msg, args, &buffer, NULL, NULL);
  979. HIDE_FROM_XFORM(va_end(args));
  980. buffer[len++] = '\n';
  981. buffer[len] = 0;
  982. scheme_write_byte_string(buffer, len,
  983. scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PORT));
  984. }
  985. void scheme_ensure_console_ready()
  986. {
  987. rktio_create_console();
  988. }
  989. void scheme_log(Scheme_Logger *logger, int level, int flags,
  990. const char *msg, ...)
  991. {
  992. GC_CAN_IGNORE va_list args;
  993. char *buffer;
  994. intptr_t len;
  995. if (logger) {
  996. if (logger->local_timestamp == SCHEME_INT_VAL(logger->root_timestamp[0]))
  997. if (logger->want_level < level)
  998. return;
  999. }
  1000. HIDE_FROM_XFORM(va_start(args, msg));
  1001. len = sch_vsprintf(NULL, 0, msg, args, &buffer, NULL, NULL);
  1002. HIDE_FROM_XFORM(va_end(args));
  1003. buffer[len] = 0;
  1004. scheme_log_message(logger, level, buffer, len, NULL);
  1005. }
  1006. void scheme_log_w_data(Scheme_Logger *logger, int level, int flags,
  1007. Scheme_Object *data,
  1008. const char *msg, ...)
  1009. {
  1010. GC_CAN_IGNORE va_list args;
  1011. char *buffer;
  1012. intptr_t len;
  1013. if (logger) {
  1014. if (logger->local_timestamp == SCHEME_INT_VAL(logger->root_timestamp[0]))
  1015. if (logger->want_level < level)
  1016. return;
  1017. }
  1018. HIDE_FROM_XFORM(va_start(args, msg));
  1019. len = sch_vsprintf(NULL, 0, msg, args, &buffer, NULL, NULL);
  1020. HIDE_FROM_XFORM(va_end(args));
  1021. buffer[len] = 0;
  1022. scheme_log_message(logger, level, buffer, len, data);
  1023. }
  1024. static char *error_write_to_string_w_max(Scheme_Object *v, int len, intptr_t *lenout)
  1025. {
  1026. Scheme_Object *o, *args[2];
  1027. o = scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PRINT_VALUE_HANDLER);
  1028. if ((SAME_OBJ(o, def_err_val_proc)
  1029. && SAME_OBJ(scheme_get_param(scheme_current_config(), MZCONFIG_PORT_PRINT_HANDLER),
  1030. scheme_default_global_print_handler))) {
  1031. intptr_t l;
  1032. char *s;
  1033. s = scheme_print_to_string_w_max(v, &l, len);
  1034. if (lenout)
  1035. *lenout = l;
  1036. return s;
  1037. } else {
  1038. Scheme_Config *config;
  1039. Scheme_Cont_Frame_Data cframe, cframe2;
  1040. args[0] = v;
  1041. args[1] = scheme_make_integer(len);
  1042. config = scheme_extend_config(scheme_current_config(),
  1043. MZCONFIG_ERROR_PRINT_VALUE_HANDLER,
  1044. def_err_val_proc);
  1045. config = scheme_extend_config(config,
  1046. MZCONFIG_PRINT_UNREADABLE,
  1047. scheme_true);
  1048. scheme_push_continuation_frame(&cframe);
  1049. scheme_install_config(config);
  1050. scheme_push_break_enable(&cframe2, 0, 0);
  1051. o = _scheme_apply(o, 2, args);
  1052. scheme_pop_break_enable(&cframe2, 0);
  1053. scheme_pop_continuation_frame(&cframe);
  1054. if (SCHEME_CHAR_STRINGP(o)) {
  1055. o = scheme_char_string_to_byte_string(o);
  1056. }
  1057. if (SCHEME_BYTE_STRINGP(o)) {
  1058. char *s = SCHEME_BYTE_STR_VAL(o);
  1059. if (SCHEME_BYTE_STRTAG_VAL(o) > len) {
  1060. char *naya;
  1061. naya = scheme_malloc_atomic(len + 1);
  1062. memcpy(naya, s, len);
  1063. s[len] = 0;
  1064. if (lenout)
  1065. *lenout = len;
  1066. } else if (lenout)
  1067. *lenout = SCHEME_BYTE_STRTAG_VAL(o);
  1068. return s;
  1069. } else {
  1070. if (lenout)
  1071. *lenout = 3;
  1072. return "...";
  1073. }
  1074. }
  1075. }
  1076. static Scheme_Object *check_arity_property_value_ok(int argc, Scheme_Object *argv[])
  1077. {
  1078. if (!scheme_check_proc_arity(NULL, 1, 0, 1, argv))
  1079. scheme_arg_mismatch("guard-for-prop:arity-string",
  1080. "property value is not a procedure (arity 1): ",
  1081. argv[0]);
  1082. return argv[0];
  1083. }
  1084. static char *make_arity_expect_string(const char *name, int namelen,
  1085. int minc, int maxc,
  1086. int argc, Scheme_Object **argv,
  1087. intptr_t *_len, int is_method,
  1088. const char *map_name)
  1089. /* minc == -1 => name is really a case-lambda, native closure, or proc-struct.
  1090. minc == -2 => use generic arity-mismatch message */
  1091. {
  1092. intptr_t len, pos, slen;
  1093. int xargc, xminc, xmaxc;
  1094. char *s, *arity_str = NULL;
  1095. const char *prefix_msg1, *prefix_msg2, *suffix_msg;
  1096. int arity_len = 0;
  1097. s = init_buf(&len, &slen);
  1098. if (!name)
  1099. name = "#<procedure>";
  1100. xargc = argc - (is_method ? 1 : 0);
  1101. xminc = minc - (is_method ? 1 : 0);
  1102. xmaxc = maxc - (is_method ? 1 : 0);
  1103. if ((minc == -1) && SCHEME_CHAPERONE_PROC_STRUCTP((Scheme_Object *)name)) {
  1104. Scheme_Object *arity_maker;
  1105. while (1) {
  1106. arity_maker = scheme_struct_type_property_ref(arity_property, (Scheme_Object *)name);
  1107. if (arity_maker) {
  1108. Scheme_Object *v, *a[1];
  1109. a[0] = (Scheme_Object *)name;
  1110. v = scheme_apply(arity_maker, 1, a);
  1111. if (SCHEME_CHAR_STRINGP(v)) {
  1112. v = scheme_char_string_to_byte_string(v);
  1113. arity_str = SCHEME_BYTE_STR_VAL(v);
  1114. arity_len = SCHEME_BYTE_STRLEN_VAL(v);
  1115. if (arity_len > len)
  1116. arity_len = len;
  1117. name = scheme_get_proc_name((Scheme_Object *)name, &namelen, 1);
  1118. if (!name) {
  1119. name = "#<procedure>";
  1120. namelen = strlen(name);
  1121. }
  1122. break;
  1123. } else
  1124. break;
  1125. } else {
  1126. Scheme_Object *v;
  1127. int is_method;
  1128. v = (Scheme_Object *)name;
  1129. if (SCHEME_CHAPERONEP(v))
  1130. v = SCHEME_CHAPERONE_VAL(v);
  1131. if (scheme_is_struct_instance(scheme_reduced_procedure_struct, v))
  1132. v = NULL; /* hide any wider type that a nested structure might report */
  1133. else
  1134. v = scheme_extract_struct_procedure(v, -1, NULL, &is_method);
  1135. if (!v || is_method || !SCHEME_CHAPERONE_PROC_STRUCTP(v))
  1136. break;
  1137. name = (const char *)v;
  1138. }
  1139. SCHEME_USE_FUEL(1);
  1140. }
  1141. if (!arity_str) {
  1142. /* If the arity is something simple, we'll make a good error
  1143. message. Otherwise, we'll just use the "no matching case"
  1144. version. */
  1145. Scheme_Object *arity;
  1146. arity = scheme_arity((Scheme_Object *)name);
  1147. if (SCHEME_INTP(arity)) {
  1148. minc = maxc = SCHEME_INT_VAL(arity);
  1149. xmaxc = xminc = minc - (is_method ? 1 : 0);
  1150. name = scheme_get_proc_name((Scheme_Object *)name, &namelen, 1);
  1151. if (!name) {
  1152. name = "#<procedure>";
  1153. namelen = strlen(name);
  1154. }
  1155. }
  1156. }
  1157. }
  1158. if (map_name) {
  1159. prefix_msg1 = map_name;
  1160. prefix_msg2 = (": argument mismatch;\n"
  1161. " the given procedure's expected number of arguments does not match\n"
  1162. " the given number of lists\n"
  1163. " given procedure: ");
  1164. suffix_msg = "";
  1165. } else {
  1166. prefix_msg1 = "";
  1167. prefix_msg2 = "";
  1168. suffix_msg = (": arity mismatch;\n"
  1169. " the expected number of arguments does not match the given number");
  1170. }
  1171. if (arity_str) {
  1172. pos = scheme_sprintf(s, slen,
  1173. "%s%s%t%s\n"
  1174. " expected: %t\n"
  1175. " given: %d",
  1176. prefix_msg1, prefix_msg2,
  1177. name, (intptr_t)namelen,
  1178. suffix_msg,
  1179. arity_str, (intptr_t)arity_len, xargc);
  1180. } else if (minc < 0) {
  1181. const char *n;
  1182. int nlen;
  1183. if (minc == -2) {
  1184. n = name;
  1185. nlen = (namelen < 0 ? strlen(n) : namelen);
  1186. } else
  1187. n = scheme_get_proc_name((Scheme_Object *)name, &nlen, 1);
  1188. if (!n) {
  1189. n = "#<case-lambda-procedure>";
  1190. nlen = strlen(n);
  1191. }
  1192. pos = scheme_sprintf(s, slen,
  1193. "%s%s%t%s\n"
  1194. " given: %d",
  1195. prefix_msg1, prefix_msg2,
  1196. n, (intptr_t)nlen,
  1197. suffix_msg,
  1198. xargc);
  1199. } else if (!maxc)
  1200. pos = scheme_sprintf(s, slen,
  1201. "%s%s%t%s\n"
  1202. " expected: 0\n"
  1203. " given: %d",
  1204. prefix_msg1, prefix_msg2,
  1205. name, (intptr_t)namelen,
  1206. suffix_msg,
  1207. xargc);
  1208. else if (maxc < 0)
  1209. pos = scheme_sprintf(s, slen,
  1210. "%s%s%t%s\n"
  1211. " expected: at least %d\n"
  1212. " given: %d",
  1213. prefix_msg1, prefix_msg2,
  1214. name, (intptr_t)namelen,
  1215. suffix_msg,
  1216. xminc, xargc);
  1217. else if (minc == maxc)
  1218. pos = scheme_sprintf(s, slen,
  1219. "%s%s%t%s\n"
  1220. " expected: %d\n"
  1221. " given: %d",
  1222. prefix_msg1, prefix_msg2,
  1223. name, (intptr_t)namelen,
  1224. suffix_msg,
  1225. xminc, xargc);
  1226. else
  1227. pos = scheme_sprintf(s, slen,
  1228. "%s%s%t%s\n"
  1229. " expected: %d to %d\n"
  1230. " given: %d",
  1231. prefix_msg1, prefix_msg2,
  1232. name, (intptr_t)namelen,
  1233. suffix_msg,
  1234. xminc, xmaxc, xargc);
  1235. if (xargc && argv) {
  1236. len -= (xargc * 4);
  1237. len /= xargc;
  1238. if ((xargc < 50) && (len >= 3)) {
  1239. int i;
  1240. for (i = (is_method ? 1 : 0); i < argc; i++) {
  1241. intptr_t l;
  1242. char *o;
  1243. if (i == (is_method ? 1 : 0)) {
  1244. strcpy(s + pos, "\n arguments...:\n ");
  1245. pos += 20;
  1246. } else {
  1247. strcpy(s + pos, "\n ");
  1248. pos += 4;
  1249. }
  1250. o = error_write_to_string_w_max(argv[i], len, &l);
  1251. memcpy(s + pos, o, l);
  1252. pos += l;
  1253. }
  1254. s[pos] = 0;
  1255. }
  1256. }
  1257. *_len = pos;
  1258. return s;
  1259. }
  1260. void scheme_wrong_count_m(const char *name, int minc, int maxc,
  1261. int argc, Scheme_Object **argv, int is_method)
  1262. /* minc == -1 => name is really a proc.
  1263. minc == -2 => use generic "no matching clause" message */
  1264. {
  1265. char *s;
  1266. intptr_t len;
  1267. Scheme_Thread *p = scheme_current_thread;
  1268. if (argv == p->tail_buffer) {
  1269. /* See calls in scheme_do_eval: */
  1270. scheme_realloc_tail_buffer(p);
  1271. }
  1272. /* minc = 1 -> name is really a case-lambda or native proc */
  1273. if (minc == -1) {
  1274. /* Extract arity, check for is_method in case-lambda, etc. */
  1275. if (SAME_TYPE(SCHEME_TYPE((Scheme_Object *)name), scheme_closure_type)) {
  1276. Scheme_Lambda *data;
  1277. data = SCHEME_CLOSURE_CODE((Scheme_Object *)name);
  1278. name = scheme_get_proc_name((Scheme_Object *)name, NULL, 1);
  1279. minc = data->num_params;
  1280. if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_REST) {
  1281. minc -= 1;
  1282. maxc = -1;
  1283. } else
  1284. maxc = minc;
  1285. } else if (SAME_TYPE(SCHEME_TYPE((Scheme_Object *)name), scheme_case_closure_type)) {
  1286. Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)name;
  1287. if (cl->count) {
  1288. Scheme_Lambda *data;
  1289. data = (Scheme_Lambda *)SCHEME_CLOSURE_CODE(cl->array[0]);
  1290. if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_IS_METHOD)
  1291. is_method = 1;
  1292. } else if (cl->name && SCHEME_BOXP(cl->name)) {
  1293. /* See note in schpriv.h about the IS_METHOD hack */
  1294. is_method = 1;
  1295. }
  1296. #ifdef MZ_USE_JIT
  1297. } else if (SAME_TYPE(SCHEME_TYPE((Scheme_Object *)name), scheme_native_closure_type)) {
  1298. Scheme_Object *pa;
  1299. pa = scheme_get_native_arity((Scheme_Object *)name, -1);
  1300. if (SCHEME_BOXP(pa)) {
  1301. pa = SCHEME_BOX_VAL(pa);
  1302. is_method = 1;
  1303. }
  1304. if (SCHEME_INTP(pa)) {
  1305. minc = SCHEME_INT_VAL(pa);
  1306. if (minc < 0) {
  1307. minc = (-minc) - 1;
  1308. maxc = -1;
  1309. } else
  1310. maxc = minc;
  1311. name = scheme_get_proc_name((Scheme_Object *)name, NULL, 1);
  1312. } else if (SCHEME_STRUCTP(pa)) {
  1313. /* This happens when a non-case-lambda is not yet JITted.
  1314. It's an arity-at-least record. */
  1315. pa = ((Scheme_Structure *)pa)->slots[0];
  1316. minc = SCHEME_INT_VAL(pa);
  1317. maxc = -1;
  1318. name = scheme_get_proc_name((Scheme_Object *)name, NULL, 1);
  1319. } else {
  1320. /* complex; use "no matching case" msg */
  1321. }
  1322. #endif
  1323. }
  1324. }
  1325. /* Watch out for impossible is_method claims: */
  1326. if (!argc || !minc)
  1327. is_method = 0;
  1328. if (maxc > SCHEME_MAX_ARGS)
  1329. maxc = -1;
  1330. s = make_arity_expect_string(name, -1, minc, maxc, argc, argv, &len, is_method, NULL);
  1331. scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY, "%t", s, len);
  1332. }
  1333. void scheme_wrong_count(const char *name, int minc, int maxc, int argc,
  1334. Scheme_Object **argv)
  1335. {
  1336. /* don't allocate here, in case rands == p->tail_buffer */
  1337. scheme_wrong_count_m(name, minc, maxc, argc, argv, 0);
  1338. }
  1339. void scheme_case_lambda_wrong_count(const char *name,
  1340. int argc, Scheme_Object **argv,
  1341. int is_method,
  1342. int count, ...)
  1343. {
  1344. char *s;
  1345. intptr_t len;
  1346. /* Watch out for impossible is_method claims: */
  1347. if (!argc)
  1348. is_method = 0;
  1349. s = make_arity_expect_string(name, -1, -2, 0, argc, argv, &len, is_method, NULL);
  1350. scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY, "%t", s, len);
  1351. }
  1352. char *scheme_make_arity_expect_string(const char *map_name,
  1353. Scheme_Object *proc,
  1354. int argc, Scheme_Object **argv,
  1355. intptr_t *_slen)
  1356. {
  1357. const char *name;
  1358. int namelen = -1;
  1359. int mina, maxa;
  1360. if (SCHEME_CHAPERONEP(proc)) {
  1361. proc = SCHEME_CHAPERONE_VAL(proc);
  1362. }
  1363. if (SCHEME_PRIMP(proc)) {
  1364. name = ((Scheme_Primitive_Proc *)proc)->name;
  1365. mina = ((Scheme_Primitive_Proc *)proc)->mina;
  1366. if (mina < 0) {
  1367. /* set min1 to -2 to indicates cases */
  1368. mina = -2;
  1369. maxa = 0;
  1370. } else {
  1371. maxa = ((Scheme_Primitive_Proc *)proc)->mu.maxa;
  1372. if (maxa > SCHEME_MAX_ARGS)
  1373. maxa = -1;
  1374. }
  1375. } else if (SCHEME_CLSD_PRIMP(proc)) {
  1376. name = ((Scheme_Closed_Primitive_Proc *)proc)->name;
  1377. mina = ((Scheme_Closed_Primitive_Proc *)proc)->mina;
  1378. maxa = ((Scheme_Closed_Primitive_Proc *)proc)->maxa;
  1379. } else if (SAME_TYPE(SCHEME_TYPE(proc), scheme_case_closure_type)) {
  1380. name = scheme_get_proc_name(proc, &namelen, 1);
  1381. mina = -2;
  1382. maxa = 0;
  1383. #ifdef MZ_USE_JIT
  1384. } else if (SAME_TYPE(SCHEME_TYPE((Scheme_Object *)proc), scheme_native_closure_type)) {
  1385. Scheme_Object *pa;
  1386. pa = scheme_get_native_arity((Scheme_Object *)proc, -1);
  1387. if (SCHEME_BOXP(pa)) {
  1388. pa = SCHEME_BOX_VAL(pa);
  1389. }
  1390. if (SCHEME_INTP(pa)) {
  1391. mina = SCHEME_INT_VAL(pa);
  1392. if (mina < 0) {
  1393. mina = (-mina) - 1;
  1394. maxa = -1;
  1395. } else
  1396. maxa = mina;
  1397. } else if (SCHEME_STRUCTP(pa)) {
  1398. /* This happens when a non-case-lambda is not yet JITted.
  1399. It's an arity-at-least record. */
  1400. pa = ((Scheme_Structure *)pa)->slots[0];
  1401. mina = SCHEME_INT_VAL(pa);
  1402. maxa = -1;
  1403. } else {
  1404. /* complex; use "no matching case" msg */
  1405. mina = -2;
  1406. maxa = 0;
  1407. }
  1408. name = scheme_get_proc_name((Scheme_Object *)proc, &namelen, 1);
  1409. #endif
  1410. } else if (SCHEME_CHAPERONE_STRUCTP(proc)) {
  1411. name = (const char *)proc;
  1412. mina = -1;
  1413. maxa = 0;
  1414. } else {
  1415. Scheme_Lambda *data;
  1416. data = (Scheme_Lambda *)SCHEME_CLOSURE_CODE(proc);
  1417. mina = maxa = data->num_params;
  1418. if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_REST) {
  1419. --mina;
  1420. maxa = -1;
  1421. }
  1422. name = scheme_get_proc_name(proc, &namelen, 1);
  1423. }
  1424. return make_arity_expect_string(name, namelen, mina, maxa, argc, argv, _slen, 0, map_name);
  1425. }
  1426. char *scheme_make_args_string(const char *s, int which, int argc, Scheme_Object **argv, intptr_t *_olen)
  1427. {
  1428. char *other;
  1429. intptr_t len;
  1430. GC_CAN_IGNORE char *isres = "arguments";
  1431. other = init_buf(&len, NULL);
  1432. if (argc < 0) {
  1433. isres = "results";
  1434. argc = -argc;
  1435. }
  1436. len /= (argc - (((which >= 0) && (argc > 1)) ? 1 : 0));
  1437. if ((argc < 50) && (len >= 3)) {
  1438. int i, pos;
  1439. sprintf(other, "; %s%s were:", s, isres);
  1440. pos = strlen(other);
  1441. for (i = 0; i < argc; i++) {
  1442. if (i != which) {
  1443. intptr_t l;
  1444. char *o;
  1445. o = error_write_to_string_w_max(argv[i], len, &l);
  1446. memcpy(other + pos, " ", 1);
  1447. memcpy(other + pos + 1, o, l);
  1448. pos += l + 1;
  1449. }
  1450. }
  1451. other[pos] = 0;
  1452. if (_olen)
  1453. *_olen = pos;
  1454. } else {
  1455. sprintf(other, "; given %d arguments total", argc);
  1456. if (_olen)
  1457. *_olen = strlen(other);
  1458. }
  1459. return other;
  1460. }
  1461. char *scheme_make_arg_lines_string(const char *indent, int which, int argc, Scheme_Object **argv, intptr_t *_olen)
  1462. {
  1463. char *other;
  1464. intptr_t len, plen;
  1465. if (!argc || ((argc == 1) && (which == 0))) {
  1466. other = " [none]";
  1467. if (_olen)
  1468. *_olen = strlen(other);
  1469. return other;
  1470. }
  1471. other = init_buf(&len, NULL);
  1472. plen = strlen(indent);
  1473. len -= ((argc - 1) * (plen + 1));
  1474. len /= (argc - (((which >= 0) && (argc > 1)) ? 1 : 0));
  1475. if (len >= 3) {
  1476. int i, pos;
  1477. pos = 0;
  1478. for (i = 0; i < argc; i++) {
  1479. if (i != which) {
  1480. intptr_t l;
  1481. char *o;
  1482. memcpy(other + pos, "\n", 1);
  1483. pos++;
  1484. memcpy(other + pos, indent, plen);
  1485. pos += plen;
  1486. o = error_write_to_string_w_max(argv[i], len, &l);
  1487. memcpy(other + pos, o, l);
  1488. pos += l;
  1489. }
  1490. }
  1491. other[pos] = 0;
  1492. if (_olen)
  1493. *_olen = pos;
  1494. } else {
  1495. sprintf(other, "... [%d total] ...", argc);
  1496. if (_olen)
  1497. *_olen = strlen(other);
  1498. }
  1499. return other;
  1500. }
  1501. const char *scheme_number_suffix(int which)
  1502. {
  1503. READ_ONLY static char *ending[] = {"st", "nd", "rd"};
  1504. if (!which)
  1505. return "th";
  1506. --which;
  1507. which = which % 100;
  1508. return ((which < 10 || which >= 20)
  1509. && ((which % 10) < 3)) ? ending[which % 10] : "th";
  1510. }
  1511. void scheme_wrong_type(const char *name, const char *expected,
  1512. int which, int argc,
  1513. Scheme_Object **argv)
  1514. {
  1515. Scheme_Object *o;
  1516. char *s;
  1517. intptr_t slen;
  1518. int isres = 0;
  1519. GC_CAN_IGNORE char *isress = "argument";
  1520. GC_CAN_IGNORE char *isgiven = "given";
  1521. o = argv[which < 0 ? 0 : which];
  1522. if (argc < 0) {
  1523. argc = -argc;
  1524. isress = "result";
  1525. isgiven = "received";
  1526. isres = 1;
  1527. }
  1528. if (which == -2) {
  1529. isress = "value";
  1530. isgiven = "received";
  1531. }
  1532. s = scheme_make_provided_string(o, 1, &slen);
  1533. if ((which < 0) || (argc == 1))
  1534. scheme_raise_exn(MZEXN_FAIL_CONTRACT,
  1535. "%s: expect%s %s of type <%s>; "
  1536. "%s: %t",
  1537. name,
  1538. (which < 0) ? "ed" : "s",
  1539. isress, expected, isgiven,
  1540. s, slen);
  1541. else {
  1542. char *other;
  1543. intptr_t olen;
  1544. if ((which >= 0) && (argc > 1))
  1545. other = scheme_make_args_string("other ", which,
  1546. (isres ? -argc : argc),
  1547. argv, &olen);
  1548. else {
  1549. other = "";
  1550. olen = 0;
  1551. }
  1552. scheme_raise_exn(MZEXN_FAIL_CONTRACT,
  1553. "%s: expects type <%s> as %d%s %s, "
  1554. "given: %t%t",
  1555. name, expected, which + 1,
  1556. scheme_number_suffix(which + 1),
  1557. isress,
  1558. s, slen, other, olen);
  1559. }
  1560. }
  1561. static const char *indent_lines(const char *s, intptr_t *_len, int initial_indent, int amt)
  1562. {
  1563. intptr_t len, i, j, lines = 1;
  1564. int a;
  1565. char *s2;
  1566. if (_len)
  1567. len = *_len;
  1568. else
  1569. len = strlen(s);
  1570. for (i = 0; i < len; i++) {
  1571. if (s[i] == '\n')
  1572. lines++;
  1573. }
  1574. if ((len > 72) || (lines > 1)) {
  1575. s2 = scheme_malloc_atomic(len + (lines * (amt + 1)) + 1);
  1576. if (initial_indent) {
  1577. s2[0] = '\n';
  1578. j = 1;
  1579. for (a = 0; a < amt; a++) {
  1580. s2[j++] = ' ';
  1581. }
  1582. } else
  1583. j = 0;
  1584. for (i = 0; i < len; i++) {
  1585. s2[j++] = s[i];
  1586. if (s[i] == '\n') {
  1587. for (a = 0; a < amt; a++) {
  1588. s2[j++] = ' ';
  1589. }
  1590. }
  1591. }
  1592. s2[j] = 0;
  1593. if (_len)
  1594. *_len = j;
  1595. return s2;
  1596. }
  1597. return s;
  1598. }
  1599. void scheme_wrong_contract(const char *name, const char *expected,
  1600. int which, int argc,
  1601. Scheme_Object **argv)
  1602. {
  1603. Scheme_Object *o;
  1604. char *s;
  1605. intptr_t slen;
  1606. int isres = 0;
  1607. GC_CAN_IGNORE char *isgiven = "given", *kind = "argument";
  1608. o = argv[which < 0 ? 0 : which];
  1609. if (argc < 0) {
  1610. argc = -argc;
  1611. isgiven = "received";
  1612. kind = "result";
  1613. isres = 1;
  1614. }
  1615. if (which == -2) {
  1616. isgiven = "received";
  1617. kind = "result";
  1618. }
  1619. if (argc == 0)
  1620. kind = "value";
  1621. s = scheme_make_provided_string(o, 1, &slen);
  1622. if ((which < 0) || (argc <= 1))
  1623. scheme_raise_exn(MZEXN_FAIL_CONTRACT,
  1624. "%s: contract violation\n"
  1625. " expected: %s\n"
  1626. " %s: %t",
  1627. name,
  1628. indent_lines(expected, NULL, 1, 3),
  1629. isgiven, s, slen);
  1630. else {
  1631. char *other;
  1632. intptr_t olen;
  1633. other = scheme_make_arg_lines_string(" ", which, argc, argv, &olen);
  1634. scheme_raise_exn(MZEXN_FAIL_CONTRACT,
  1635. "%s: contract violation\n"
  1636. " expected: %s\n"
  1637. " %s: %t\n"
  1638. " %s position: %d%s\n"
  1639. " other %s...:%s",
  1640. name,
  1641. indent_lines(expected, NULL, 1, 3),
  1642. isgiven, s, slen,
  1643. kind, which + 1, scheme_number_suffix(which + 1),
  1644. (!isres ? "arguments" : "results"), other, olen);
  1645. }
  1646. }
  1647. void scheme_wrong_field_type(Scheme_Object *c_name,
  1648. const char *expected,
  1649. Scheme_Object *o)
  1650. {
  1651. const char *s;
  1652. Scheme_Object *a[1];
  1653. a[0] = o;
  1654. s = scheme_symbol_name(c_name);
  1655. scheme_wrong_type(s, expected, -1, 0, a);
  1656. }
  1657. void scheme_wrong_field_contract(Scheme_Object *c_name,
  1658. const char *expected,
  1659. Scheme_Object *o)
  1660. {
  1661. const char *s;
  1662. Scheme_Object *a[1];
  1663. a[0] = o;
  1664. s = scheme_symbol_name(c_name);
  1665. scheme_wrong_contract(s, expected, -1, 0, a);
  1666. }
  1667. void scheme_arg_mismatch(const char *name, const char *msg, Scheme_Object *o)
  1668. {
  1669. char *s;
  1670. intptr_t slen;
  1671. if (o)
  1672. s = scheme_make_provided_string(o, 1, &slen);
  1673. else {
  1674. s = "";
  1675. slen = 0;
  1676. }
  1677. scheme_raise_exn(MZEXN_FAIL_CONTRACT,
  1678. "%s: %s%t",
  1679. name, msg, s, slen);
  1680. }
  1681. static void do_out_of_range(const char *name, const char *type, const char *which,
  1682. int ending,
  1683. Scheme_Object *i, Scheme_Object *s,
  1684. Scheme_Object *low_bound, Scheme_Object *sstart, Scheme_Object *slen)
  1685. {
  1686. if (!type) {
  1687. type = (SCHEME_BYTE_STRINGP(s) ? "byte string" : "string");
  1688. }
  1689. if (!scheme_bin_lt(slen, sstart)) {
  1690. char *sstr;
  1691. intptr_t strlen;
  1692. int small_end = 0;
  1693. if (ending) {
  1694. if (scheme_bin_gt_eq(i, low_bound)
  1695. && scheme_bin_lt(i, sstart))
  1696. small_end = 1;
  1697. }
  1698. sstr = scheme_make_provided_string(s, 2, &strlen);
  1699. scheme_raise_exn(MZEXN_FAIL_CONTRACT,
  1700. "%s: %sindex is %s\n %sindex: %s\n %s%V%s%V]\n %s: %t",
  1701. name, which,
  1702. small_end ? "smaller than starting index" : "out of range",
  1703. which, scheme_make_provided_string(i, 2, NULL),
  1704. ending ? "starting index: " : "valid range: [",
  1705. sstart,
  1706. ending ? "\n valid range: [0, " : ", ",
  1707. slen,
  1708. type,
  1709. sstr, strlen);
  1710. } else {
  1711. scheme_raise_exn(MZEXN_FAIL_CONTRACT,
  1712. "%s: %sindex is out of range for empty %s\n %sindex: %s",
  1713. name, which,
  1714. type,
  1715. which, scheme_make_provided_string(i, 0, NULL));
  1716. }
  1717. }
  1718. void scheme_out_of_range(const char *name, const char *type, const char *which,
  1719. Scheme_Object *i, Scheme_Object *s,
  1720. intptr_t start, intptr_t len)
  1721. {
  1722. if (start < 0) {
  1723. start = 0;
  1724. len = len - 1;
  1725. }
  1726. do_out_of_range(name, type, which, !strcmp(which, "ending "),
  1727. i, s, scheme_make_integer(0), scheme_make_integer(start), scheme_make_integer(len));
  1728. }
  1729. static Scheme_Object *raise_range_error(int argc, Scheme_Object *argv[])
  1730. {
  1731. Scheme_Object *type, *desc;
  1732. if (!SCHEME_SYMBOLP(argv[0]))
  1733. scheme_wrong_contract("raise-range-error", "symbol?", 0, argc, argv);
  1734. if (!SCHEME_CHAR_STRINGP(argv[1]))
  1735. scheme_wrong_contract("raise-range-error", "string?", 1, argc, argv);
  1736. if (!SCHEME_CHAR_STRINGP(argv[2]))
  1737. scheme_wrong_contract("raise-range-error", "string?", 2, argc, argv);
  1738. if (!SCHEME_INTP(argv[3]) && !SCHEME_BIGNUMP(argv[3]))
  1739. scheme_wrong_contract("raise-range-error", "exact-integer?", 3, argc, argv);
  1740. if (!SCHEME_INTP(argv[5]) && !SCHEME_BIGNUMP(argv[5]))
  1741. scheme_wrong_contract("raise-range-error", "exact-integer?", 5, argc, argv);
  1742. if (!SCHEME_INTP(argv[6]) && !SCHEME_BIGNUMP(argv[6]))
  1743. scheme_wrong_contract("raise-range-error", "exact-integer?", 6, argc, argv);
  1744. if (argc > 7) {
  1745. if (!SCHEME_FALSEP(argv[7]) && !SCHEME_INTP(argv[7]) && !SCHEME_BIGNUMP(argv[7]))
  1746. scheme_wrong_contract("raise-range-error", "(or/c exact-integer? #f)", 7, argc, argv);
  1747. }
  1748. type = scheme_char_string_to_byte_string(argv[1]);
  1749. desc = scheme_char_string_to_byte_string(argv[2]);
  1750. do_out_of_range(scheme_symbol_val(argv[0]),
  1751. SCHEME_BYTE_STR_VAL(type), /* type */
  1752. SCHEME_BYTE_STR_VAL(desc), /* index description */
  1753. ((argc > 7) && SCHEME_TRUEP(argv[7])),
  1754. argv[3], /* index */
  1755. argv[4], /* in value */
  1756. argv[7], /* lower bound */
  1757. argv[5], /* start */
  1758. argv[6]); /* end */
  1759. return scheme_void;
  1760. }
  1761. #define MAX_MISMATCH_EXTRAS 5
  1762. void scheme_contract_error(const char *name, const char *msg, ...)
  1763. {
  1764. GC_CAN_IGNORE va_list args;
  1765. int i, cnt = 0, kind;
  1766. intptr_t len = 0, nlen, mlen, seplen;
  1767. const char *strs[MAX_MISMATCH_EXTRAS], *str, *sep;
  1768. Scheme_Object *vs[MAX_MISMATCH_EXTRAS], *v;
  1769. const char *v_strs[MAX_MISMATCH_EXTRAS], *v_str;
  1770. intptr_t v_str_lens[MAX_MISMATCH_EXTRAS], v_str_len;
  1771. char *s;
  1772. HIDE_FROM_XFORM(va_start(args, msg));
  1773. while (1) {
  1774. str = mzVA_ARG(args, const char *);
  1775. if (!str) break;
  1776. strs[cnt] = str;
  1777. kind = mzVA_ARG(args, int);
  1778. if (kind) {
  1779. v = mzVA_ARG(args, Scheme_Object *);
  1780. vs[cnt++] = v;
  1781. } else {
  1782. str = mzVA_ARG(args, const char *);
  1783. v_strs[cnt] = str;
  1784. v_str_lens[cnt] = strlen(str);
  1785. vs[cnt++] = NULL;
  1786. }
  1787. }
  1788. HIDE_FROM_XFORM(va_end(args));
  1789. for (i = 0; i < cnt; i++) {
  1790. if (vs[i]) {
  1791. v_str = scheme_make_provided_string(vs[i], 1, &v_str_len);
  1792. v_strs[i] = v_str;
  1793. v_str_lens[i] = v_str_len;
  1794. } else
  1795. v_str_len = v_str_lens[i];
  1796. len += v_str_len + 5 + strlen(strs[i]);
  1797. }
  1798. sep = ": ";
  1799. mlen = strlen(msg);
  1800. nlen = strlen(name);
  1801. seplen = strlen(sep);
  1802. len += mlen + nlen + seplen + 10;
  1803. s = scheme_malloc_atomic(len);
  1804. len = 0;
  1805. memcpy(s, name, nlen);
  1806. len += nlen;
  1807. memcpy(s + len, sep, seplen);
  1808. len += seplen;
  1809. memcpy(s + len, msg, mlen);
  1810. len += mlen;
  1811. for (i = 0; i < cnt; i++) {
  1812. memcpy(s + len, "\n ", 3);
  1813. len += 3;
  1814. nlen = strlen(strs[i]);
  1815. memcpy(s + len, strs[i], nlen);
  1816. len += nlen;
  1817. memcpy(s + len, ": ", 2);
  1818. len += 2;
  1819. memcpy(s + len, v_strs[i], v_str_lens[i]);
  1820. len += v_str_lens[i];
  1821. }
  1822. s[len] = 0;
  1823. scheme_raise_exn(MZEXN_FAIL_CONTRACT,
  1824. "%t",
  1825. s, len);
  1826. }
  1827. void scheme_wrong_chaperoned(const char *who, const char *what, Scheme_Object *orig, Scheme_Object *naya)
  1828. {
  1829. char buf[128];
  1830. sprintf(buf,
  1831. "non-chaperone result;\n"
  1832. " received a %s that is not a chaperone of the original %s",
  1833. what, what);
  1834. scheme_contract_error(who,
  1835. buf,
  1836. "original", 1, orig,
  1837. "received", 1, naya,
  1838. NULL);
  1839. }
  1840. void scheme_system_error(const char *name, const char *what, int errid)
  1841. {
  1842. scheme_raise_exn(MZEXN_FAIL,
  1843. "%s: %s failed\n"
  1844. " system error: %e",
  1845. name, what, errid);
  1846. }
  1847. void scheme_rktio_error(const char *name, const char *what)
  1848. {
  1849. scheme_raise_exn(MZEXN_FAIL,
  1850. "%s: %s failed\n"
  1851. " system error: %R",
  1852. name, what);
  1853. }
  1854. #define MZERR_MAX_SRC_LEN 100
  1855. static char *make_srcloc_string(Scheme_Object *src, intptr_t line, intptr_t col, intptr_t pos, intptr_t *len)
  1856. {
  1857. char *srcstr, *result;
  1858. intptr_t srclen, rlen;
  1859. if (!src || (SCHEME_FALSEP(src) && (pos < 0))) {
  1860. if (len) *len = 0;
  1861. return NULL;
  1862. }
  1863. if (col < 0)
  1864. col = pos + 1;
  1865. if (src && SCHEME_PATHP(src)) {
  1866. /* Strip off prefix matching the current directory: */
  1867. src = scheme_remove_current_directory_prefix(src);
  1868. /* Truncate from the front, to get the interesting part of paths: */
  1869. srclen = SCHEME_BYTE_STRLEN_VAL(src);
  1870. if (srclen > MZERR_MAX_SRC_LEN) {
  1871. srcstr = scheme_malloc_atomic(MZERR_MAX_SRC_LEN);
  1872. memcpy(srcstr, SCHEME_BYTE_STR_VAL(src) + (srclen - MZERR_MAX_SRC_LEN),
  1873. MZERR_MAX_SRC_LEN);
  1874. srcstr[0] = '.';
  1875. srcstr[1] = '.';
  1876. srcstr[2] = '.';
  1877. srclen = MZERR_MAX_SRC_LEN;
  1878. } else
  1879. srcstr = SCHEME_BYTE_STR_VAL(src);
  1880. } else
  1881. srcstr = scheme_display_to_string_w_max(src, &srclen, MZERR_MAX_SRC_LEN);
  1882. result = (char *)scheme_malloc_atomic(srclen + 15);
  1883. if (col >= 0) {
  1884. rlen = scheme_sprintf(result, srclen + 15, "%t:%L%ld",
  1885. srcstr, srclen, line, col-1);
  1886. } else {
  1887. rlen = scheme_sprintf(result, srclen + 15, "%t::",
  1888. srcstr, srclen);
  1889. }
  1890. if (len) *len = rlen;
  1891. return result;
  1892. }
  1893. static char *make_stx_srcloc_string(Scheme_Stx_Srcloc *srcloc, intptr_t *len)
  1894. {
  1895. return make_srcloc_string(srcloc->src, srcloc->line, srcloc->col, srcloc->pos, len);
  1896. }
  1897. char *scheme_make_srcloc_string(Scheme_Object *stx, intptr_t *len)
  1898. {
  1899. return make_stx_srcloc_string(((Scheme_Stx *)stx)->srcloc, len);
  1900. }
  1901. static intptr_t struct_number_ref(Scheme_Object *s, int pos)
  1902. {
  1903. s = scheme_struct_ref(s, pos);
  1904. if (SCHEME_FALSEP(s))
  1905. return -1;
  1906. else
  1907. return SCHEME_INT_VAL(s);
  1908. }
  1909. Scheme_Object *srcloc_to_string(int argc, Scheme_Object **argv)
  1910. {
  1911. Scheme_Object *src;
  1912. char *s;
  1913. intptr_t len, line, col, pos;
  1914. if (!scheme_is_location(argv[0]))
  1915. scheme_wrong_contract("srcloc->string", "srcloc?", 0, argc, argv);
  1916. src = scheme_struct_ref(argv[0], 0);
  1917. if (SCHEME_FALSEP(src)) src = NULL;
  1918. line = struct_number_ref(argv[0], 1);
  1919. col = struct_number_ref(argv[0], 2);
  1920. pos = struct_number_ref(argv[0], 3);
  1921. s = make_srcloc_string(src, line, (col >= 0 ? col+1 : -1), pos, &len);
  1922. if (s)
  1923. return scheme_make_sized_utf8_string(s, len);
  1924. else
  1925. return scheme_false;
  1926. }
  1927. static Scheme_Object *unquoted_printing_string(int argc, Scheme_Object **argv)
  1928. {
  1929. Scheme_Object *o;
  1930. if (!SCHEME_CHAR_STRINGP(argv[0]))
  1931. scheme_wrong_contract("unquoted-printing-string", "string?", 0, argc, argv);
  1932. o = scheme_alloc_small_object();
  1933. o->type = scheme_unquoted_printing_string_type;
  1934. SCHEME_PTR_VAL(o) = argv[0];
  1935. return o;
  1936. }
  1937. static Scheme_Object *unquoted_printing_string_p(int argc, Scheme_Object **argv)
  1938. {
  1939. return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_unquoted_printing_string_type)
  1940. ? scheme_true
  1941. : scheme_false);
  1942. }
  1943. static Scheme_Object *unquoted_printing_string_value(int argc, Scheme_Object **argv)
  1944. {
  1945. if (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_unquoted_printing_string_type))
  1946. return SCHEME_PTR_VAL(argv[0]);
  1947. scheme_wrong_contract("unquoted-printing-string-value", "unquoted-printing-string?", 0, argc, argv);
  1948. return NULL;
  1949. }
  1950. void scheme_read_err(Scheme_Object *port,
  1951. const char *detail, ...)
  1952. {
  1953. GC_CAN_IGNORE va_list args;
  1954. Scheme_Object *pn;
  1955. char *s, *fn;
  1956. intptr_t slen;
  1957. HIDE_FROM_XFORM(va_start(args, detail));
  1958. slen = sch_vsprintf(NULL, 0, detail, args, &s, NULL, NULL);
  1959. HIDE_FROM_XFORM(va_end(args));
  1960. if (port) {
  1961. pn = scheme_input_port_record(port)->name;
  1962. if (SCHEME_PATHP(pn)) {
  1963. pn = scheme_remove_current_directory_prefix(pn);
  1964. fn = SCHEME_PATH_VAL(pn);
  1965. } else
  1966. fn = NULL;
  1967. } else
  1968. fn = NULL;
  1969. if (fn)
  1970. scheme_raise_exn(MZEXN_FAIL_READ, scheme_null, "%t\n in: %s", s, slen, fn);
  1971. else
  1972. scheme_raise_exn(MZEXN_FAIL_READ, scheme_null, "%t", s, slen);
  1973. }
  1974. Scheme_Object *scheme_numr_err(Scheme_Object *complain, const char *detail, ...)
  1975. {
  1976. GC_CAN_IGNORE va_list args;
  1977. char *s;
  1978. intptr_t slen;
  1979. HIDE_FROM_XFORM(va_start(args, detail));
  1980. slen = sch_vsprintf(NULL, 0, detail, args, &s, NULL, NULL);
  1981. HIDE_FROM_XFORM(va_end(args));
  1982. if (SCHEME_FALSEP(complain))
  1983. return scheme_make_sized_utf8_string(s, slen);
  1984. scheme_read_err(complain, "read: %s", s);
  1985. ESCAPED_BEFORE_HERE;
  1986. }
  1987. static void do_wrong_syntax(const char *where,
  1988. Scheme_Object *detail_form,
  1989. Scheme_Object *form,
  1990. char *s, intptr_t slen)
  1991. {
  1992. intptr_t len, vlen, dvlen, blen, plen;
  1993. char *buffer;
  1994. char *v, *dv, *p;
  1995. Scheme_Object *who;
  1996. int show_src;
  1997. who = NULL;
  1998. if (!s) {
  1999. s = "bad syntax";
  2000. slen = strlen(s);
  2001. }
  2002. buffer = init_buf(&len, &blen);
  2003. p = NULL;
  2004. plen = 0;
  2005. show_src = SCHEME_TRUEP(scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PRINT_SRCLOC));
  2006. if (form) {
  2007. Scheme_Object *pform;
  2008. if (SCHEME_STXP(form)) {
  2009. p = make_stx_srcloc_string(((Scheme_Stx *)form)->srcloc, &plen);
  2010. pform = scheme_syntax_to_datum(form);
  2011. /* Try to extract syntax name from syntax */
  2012. if (!who && (SCHEME_STX_SYMBOLP(form) || SCHEME_STX_PAIRP(form))) {
  2013. Scheme_Object *first;
  2014. if (SCHEME_STX_PAIRP(form))
  2015. first = SCHEME_STX_CAR(form);
  2016. else
  2017. first = form;
  2018. if (SCHEME_STX_SYMBOLP(first))
  2019. who = SCHEME_STX_SYM(first); /* printed name is local name */
  2020. }
  2021. } else {
  2022. pform = form;
  2023. }
  2024. /* don't use error_write_to_string_w_max since this is code */
  2025. if (show_src)
  2026. v = scheme_write_to_string_w_max(pform, &vlen, len);
  2027. else {
  2028. v = NULL;
  2029. vlen = 0;
  2030. }
  2031. } else {
  2032. form = scheme_false;
  2033. v = NULL;
  2034. vlen = 0;
  2035. }
  2036. if (detail_form) {
  2037. Scheme_Object *pform;
  2038. if (SCHEME_STXP(detail_form)) {
  2039. if (((Scheme_Stx *)detail_form)->srcloc->line >= 0)
  2040. p = make_stx_srcloc_string(((Scheme_Stx *)detail_form)->srcloc, &plen);
  2041. }
  2042. pform = scheme_syntax_to_datum(detail_form);
  2043. /* don't use error_write_to_string_w_max since this is code */
  2044. if (show_src)
  2045. dv = scheme_write_to_string_w_max(pform, &dvlen, len);
  2046. else {
  2047. dv = NULL;
  2048. dvlen = 0;
  2049. }
  2050. } else {
  2051. dv = NULL;
  2052. dvlen = 0;
  2053. }
  2054. if (!who) {
  2055. if (where)
  2056. who = scheme_intern_symbol(where);
  2057. else
  2058. who = scheme_false;
  2059. }
  2060. if (!where) {
  2061. if (SCHEME_FALSEP(who))
  2062. where = "?";
  2063. else
  2064. where = scheme_symbol_val(who);
  2065. }
  2066. if (v) {
  2067. if (dv)
  2068. blen = scheme_sprintf(buffer, blen,
  2069. "%t%s%s: %t\n"
  2070. " at: %t\n"
  2071. " in: %t",
  2072. p, plen,
  2073. p ? ": " : "",
  2074. where,
  2075. s, slen,
  2076. dv, dvlen,
  2077. v, vlen);
  2078. else
  2079. blen = scheme_sprintf(buffer, blen,
  2080. "%t%s%s: %t\n"
  2081. " in: %t",
  2082. p, plen,
  2083. p ? ": " : "",
  2084. where,
  2085. s, slen,
  2086. v, vlen);
  2087. } else if (dv)
  2088. blen = scheme_sprintf(buffer, blen,
  2089. "%t%s%s: %t\n"
  2090. " at: %t",
  2091. p, plen,
  2092. p ? ": " : "",
  2093. where,
  2094. s, slen,
  2095. dv, dvlen);
  2096. else
  2097. blen = scheme_sprintf(buffer, blen, "%s: %t",
  2098. where,
  2099. s, slen);
  2100. scheme_raise_exn(MZEXN_FAIL_CONTRACT,
  2101. "%t", buffer, blen);
  2102. }
  2103. void scheme_wrong_syntax(const char *where,
  2104. Scheme_Object *detail_form,
  2105. Scheme_Object *form,
  2106. const char *detail, ...)
  2107. {
  2108. char *s;
  2109. intptr_t slen;
  2110. if (!detail) {
  2111. s = NULL;
  2112. slen = 0;
  2113. } else {
  2114. GC_CAN_IGNORE va_list args;
  2115. HIDE_FROM_XFORM(va_start(args, detail));
  2116. slen = sch_vsprintf(NULL, 0, detail, args, &s, NULL, NULL);
  2117. HIDE_FROM_XFORM(va_end(args));
  2118. }
  2119. do_wrong_syntax(where, detail_form, form, s, slen);
  2120. }
  2121. void scheme_wrong_rator(Scheme_Object *rator, int argc, Scheme_Object **argv)
  2122. {
  2123. intptr_t slen, rlen;
  2124. char *s, *r;
  2125. r = scheme_make_provided_string(rator, 1, &rlen);
  2126. s = scheme_make_arg_lines_string(" ", -1, argc, argv, &slen);
  2127. scheme_raise_exn(MZEXN_FAIL_CONTRACT,
  2128. "application: not a procedure;\n"
  2129. " expected a procedure that can be applied to arguments\n"
  2130. " given: %t\n"
  2131. " arguments...:%t",
  2132. r, rlen, s, slen);
  2133. }
  2134. void scheme_wrong_return_arity(const char *where,
  2135. int expected, int got,
  2136. Scheme_Object **argv,
  2137. const char *detail, ...)
  2138. {
  2139. intptr_t slen, vlen, blen;
  2140. char *s, *buffer;
  2141. char *v;
  2142. if ((got != 1) && SAME_OBJ(scheme_current_thread->ku.multiple.array,
  2143. scheme_current_thread->values_buffer))
  2144. scheme_current_thread->values_buffer = NULL;
  2145. scheme_current_thread->ku.multiple.array = NULL;
  2146. if (!detail) {
  2147. s = NULL;
  2148. slen = 0;
  2149. } else {
  2150. GC_CAN_IGNORE va_list args;
  2151. HIDE_FROM_XFORM(va_start(args, detail));
  2152. slen = sch_vsprintf(NULL, 0, detail, args, &s, NULL, NULL);
  2153. HIDE_FROM_XFORM(va_end(args));
  2154. }
  2155. buffer = init_buf(NULL, &blen);
  2156. if (!got || !argv) {
  2157. v = "";
  2158. vlen = 0;
  2159. } else {
  2160. Scheme_Object **array;
  2161. array = ((got == 1) ? (Scheme_Object **) mzALIAS &argv : argv);
  2162. v = scheme_make_arg_lines_string(" ", -1, got, array, &vlen);
  2163. }
  2164. blen = scheme_sprintf(buffer,
  2165. blen,
  2166. "%s%sresult arity mismatch;\n"
  2167. " expected number of values not received\n"
  2168. " expected: %d\n"
  2169. " received: %d"
  2170. "%t\n"
  2171. " values...:%t",
  2172. where ? where : "",
  2173. where ? ": " : "",
  2174. expected,
  2175. got,
  2176. s, slen,
  2177. v, vlen);
  2178. scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY,
  2179. "%t",
  2180. buffer, blen);
  2181. }
  2182. void scheme_non_fixnum_result(const char *name, Scheme_Object *o)
  2183. {
  2184. scheme_raise_exn(MZEXN_FAIL_CONTRACT_NON_FIXNUM_RESULT,
  2185. "%s: result is not a fixnum\n"
  2186. " result: %V",
  2187. name, o);
  2188. }
  2189. void scheme_raise_out_of_memory(const char *where, const char *msg, ...)
  2190. {
  2191. char *s;
  2192. intptr_t slen;
  2193. if (!msg) {
  2194. s = "";
  2195. slen = 0;
  2196. } else {
  2197. GC_CAN_IGNORE va_list args;
  2198. HIDE_FROM_XFORM(va_start(args, msg));
  2199. slen = sch_vsprintf(NULL, 0, msg, args, &s, NULL, NULL);
  2200. HIDE_FROM_XFORM(va_end(args));
  2201. }
  2202. scheme_raise_exn(MZEXN_FAIL_OUT_OF_MEMORY,
  2203. "%s%sout of memory %t",
  2204. where ? where : "",
  2205. where ? ": " : "",
  2206. s, slen);
  2207. }
  2208. void scheme_unbound_global(Scheme_Bucket *b)
  2209. {
  2210. Scheme_Object *name = (Scheme_Object *)b->key;
  2211. Scheme_Instance *home;
  2212. home = scheme_get_bucket_home(b);
  2213. if (home) {
  2214. Scheme_Object *src_name;
  2215. const char *errmsg;
  2216. src_name = scheme_hash_tree_get(home->source_names, name);
  2217. if (!src_name)
  2218. src_name = name;
  2219. if (SCHEME_TRUEP(scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PRINT_SRCLOC))) {
  2220. if (!SAME_OBJ(name, src_name))
  2221. errmsg = ("%S: undefined;\n"
  2222. " cannot reference an identifier before its definition\n"
  2223. " in module: %D\n"
  2224. " internal name: %S");
  2225. else
  2226. errmsg = ("%S: undefined;\n"
  2227. " cannot reference an identifier before its definition\n"
  2228. " in module: %D");
  2229. } else
  2230. errmsg = ("%S: undefined;\n"
  2231. " cannot reference an identifier before its definition%_%_");
  2232. scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE,
  2233. name,
  2234. errmsg,
  2235. src_name,
  2236. home->name,
  2237. name);
  2238. } else {
  2239. scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE,
  2240. name,
  2241. "%S: undefined;\n"
  2242. " cannot reference undefined identifier",
  2243. name);
  2244. }
  2245. }
  2246. char *scheme_make_provided_string(Scheme_Object *o, int count, intptr_t *lenout)
  2247. {
  2248. intptr_t len;
  2249. len = scheme_get_print_width();
  2250. if (count)
  2251. len /= count;
  2252. return error_write_to_string_w_max(o, len, lenout);
  2253. }
  2254. static char *make_provided_list(Scheme_Object *o, int count, intptr_t *lenout)
  2255. {
  2256. intptr_t len, cnt, i, onelen, total, sz;
  2257. char *s, *accum, *naya;
  2258. cnt = scheme_proper_list_length(o);
  2259. if (cnt < 0)
  2260. return scheme_make_provided_string(o, count, lenout);
  2261. if (!cnt) {
  2262. *lenout = 0;
  2263. return "";
  2264. }
  2265. len = scheme_get_print_width();
  2266. if (count)
  2267. len /= count;
  2268. total = 0;
  2269. sz = 64;
  2270. accum = (char *)scheme_malloc_atomic(sz);
  2271. for (i = 0; i < cnt; i++) {
  2272. s = scheme_write_to_string_w_max(SCHEME_CAR(o), &onelen, len / cnt);
  2273. if (total + onelen + 1 >= sz) {
  2274. sz = (2 * sz) + onelen + 1;
  2275. naya = (char *)scheme_malloc_atomic(sz);
  2276. memcpy(naya, accum, total);
  2277. accum = naya;
  2278. }
  2279. memcpy(accum + total, s, onelen);
  2280. accum[total + onelen] = ' ';
  2281. total += onelen + 1;
  2282. o = SCHEME_CDR(o);
  2283. }
  2284. total -= 1;
  2285. accum[total] = 0;
  2286. *lenout = total;
  2287. return accum;
  2288. }
  2289. static Scheme_Object *do_error(const char *who, int mode, int argc, Scheme_Object *argv[])
  2290. {
  2291. Scheme_Object *newargs[2];
  2292. if (SCHEME_SYMBOLP(argv[0])) {
  2293. if (argc < 2) {
  2294. const char *s;
  2295. int l;
  2296. s = scheme_symbol_val(argv[0]);
  2297. l = SCHEME_SYM_LEN(argv[0]);
  2298. /* Just a symbol */
  2299. newargs[0] =
  2300. scheme_append_char_string(scheme_make_utf8_string("error: "),
  2301. scheme_make_sized_utf8_string((char *)s, l));
  2302. SCHEME_SET_CHAR_STRING_IMMUTABLE(newargs[0]);
  2303. } else {
  2304. char *s, *r;
  2305. intptr_t l, l2;
  2306. Scheme_Object *port;
  2307. port = scheme_make_byte_string_output_port();
  2308. /* Chez-style: symbol, format string, format items... */
  2309. if (!SCHEME_CHAR_STRINGP(argv[1]))
  2310. scheme_wrong_contract(who, "string?", 1, argc, argv);
  2311. scheme_do_format(who, port, NULL, -1, 1, 2, argc, argv);
  2312. s = scheme_get_sized_byte_string_output(port, &l);
  2313. l2 = SCHEME_SYM_LEN(argv[0]);
  2314. r = MALLOC_N_ATOMIC(char, l + l2 + 3);
  2315. memcpy(r, SCHEME_SYM_VAL(argv[0]), l2);
  2316. memcpy(r + l2, ": ", 2);
  2317. memcpy(r + l2 + 2, s, l + 1);
  2318. newargs[0] = scheme_make_immutable_sized_utf8_string(r, l + l2 + 2);
  2319. }
  2320. } else {
  2321. Scheme_Object *strout;
  2322. char *str;
  2323. intptr_t len, i;
  2324. /* String followed by other values: */
  2325. if (!SCHEME_CHAR_STRINGP(argv[0]))
  2326. scheme_wrong_contract(who, "(or/c string? symbol?)", 0, argc, argv);
  2327. strout = scheme_make_byte_string_output_port();
  2328. scheme_internal_display(argv[0], strout);
  2329. for (i = 1; i < argc ; i++) {
  2330. scheme_write_byte_string(" ", 1, strout);
  2331. scheme_internal_write(argv[i], strout);
  2332. }
  2333. str = scheme_get_sized_byte_string_output(strout, &len);
  2334. newargs[0] = scheme_make_immutable_sized_utf8_string(str, len);
  2335. }
  2336. newargs[1] = TMP_CMARK_VALUE;
  2337. do_raise(scheme_make_struct_instance(exn_table[mode].type,
  2338. 2, newargs),
  2339. 1,
  2340. 1);
  2341. return scheme_void;
  2342. }
  2343. static Scheme_Object *error(int argc, Scheme_Object *argv[])
  2344. {
  2345. return do_error("error", MZEXN_FAIL, argc, argv);
  2346. }
  2347. static Scheme_Object *raise_user_error(int argc, Scheme_Object *argv[])
  2348. {
  2349. return do_error("raise-user-error", MZEXN_FAIL_USER, argc, argv);
  2350. }
  2351. typedef void (*wrong_proc_t)(const char *name, const char *expected,
  2352. int which, int argc,
  2353. Scheme_Object **argv);
  2354. static Scheme_Object *do_raise_type_error(const char *name, int argc, Scheme_Object *argv[], int mode)
  2355. {
  2356. wrong_proc_t wrong;
  2357. int negate = 0;
  2358. if (!SCHEME_SYMBOLP(argv[0]))
  2359. scheme_wrong_contract(name, "symbol?", 0, argc, argv);
  2360. if (!SCHEME_CHAR_STRINGP(argv[1]))
  2361. scheme_wrong_contract(name, "string?", 1, argc, argv);
  2362. switch (mode) {
  2363. case 0: wrong = scheme_wrong_type; break;
  2364. case 1: wrong = scheme_wrong_contract; break;
  2365. case 2: wrong = scheme_wrong_contract; negate = 1; break;
  2366. default: wrong = NULL; break;
  2367. }
  2368. if (argc == 3) {
  2369. Scheme_Object *v, *s;
  2370. v = argv[2];
  2371. s = scheme_char_string_to_byte_string(argv[1]);
  2372. wrong(scheme_symbol_val(argv[0]),
  2373. SCHEME_BYTE_STR_VAL(s),
  2374. negate ? -2 : -1, 0, &v);
  2375. } else {
  2376. Scheme_Object **args, *s;
  2377. int i;
  2378. if (!(SCHEME_INTP(argv[2]) && (SCHEME_INT_VAL(argv[2]) >= 0))
  2379. && !(SCHEME_BIGNUMP(argv[2]) && SCHEME_BIGPOS(argv[2])))
  2380. scheme_wrong_contract(name, "exact-nonnegative-integer?", 2, argc, argv);
  2381. if ((SCHEME_INTP(argv[2]) && (SCHEME_INT_VAL(argv[2]) >= argc - 3))
  2382. || SCHEME_BIGNUMP(argv[2]))
  2383. scheme_contract_error(name,
  2384. (negate
  2385. ? "position index >= provided result count"
  2386. : "position index >= provided argument count"),
  2387. "position index", 1, argv[2],
  2388. (negate ? "provided result count" : "provided argument count"),
  2389. 1,
  2390. scheme_make_integer(argc - 3),
  2391. NULL);
  2392. args = MALLOC_N(Scheme_Object *, argc - 3);
  2393. for (i = 3; i < argc; i++) {
  2394. args[i - 3] = argv[i];
  2395. }
  2396. s = scheme_char_string_to_byte_string(argv[1]);
  2397. wrong(scheme_symbol_val(argv[0]),
  2398. SCHEME_BYTE_STR_VAL(s),
  2399. SCHEME_INT_VAL(argv[2]),
  2400. negate ? (3 - argc) : (argc - 3), args);
  2401. }
  2402. return NULL;
  2403. }
  2404. static Scheme_Object *raise_type_error(int argc, Scheme_Object *argv[])
  2405. {
  2406. return do_raise_type_error("raise-type-error", argc, argv, 0);
  2407. }
  2408. static Scheme_Object *raise_argument_error(int argc, Scheme_Object *argv[])
  2409. {
  2410. return do_raise_type_error("raise-argument-error", argc, argv, 1);
  2411. }
  2412. static Scheme_Object *raise_result_error(int argc, Scheme_Object *argv[])
  2413. {
  2414. return do_raise_type_error("raise-result-error", argc, argv, 2);
  2415. }
  2416. static Scheme_Object *do_raise_mismatch_error(const char *who, int mismatch, int argc, Scheme_Object *argv[])
  2417. {
  2418. Scheme_Object *s;
  2419. int i;
  2420. char *s2;
  2421. intptr_t l2;
  2422. if (!SCHEME_SYMBOLP(argv[0]))
  2423. scheme_wrong_contract(who, "symbol?", 0, argc, argv);
  2424. if (!SCHEME_CHAR_STRINGP(argv[1]))
  2425. scheme_wrong_contract(who, "string?", 1, argc, argv);
  2426. /* additional arguments: alternate ones must be strings */
  2427. for (i = 2 + mismatch; i < argc; i += 2) {
  2428. if (!SCHEME_CHAR_STRINGP(argv[i]))
  2429. scheme_wrong_contract(who, "string?", i, argc, argv);
  2430. }
  2431. if (!mismatch && (argc & 1)) {
  2432. scheme_contract_error(who,
  2433. "missing value after field string",
  2434. "field string", 1, argv[argc-1],
  2435. NULL);
  2436. }
  2437. if (!mismatch && (argc == 2)) {
  2438. /* Simple case: one string & value: */
  2439. s = scheme_char_string_to_byte_string(argv[1]);
  2440. scheme_contract_error(scheme_symbol_val(argv[0]),
  2441. SCHEME_BYTE_STR_VAL(s),
  2442. NULL);
  2443. } else if (mismatch && (argc == 3)) {
  2444. /* Simple case: one string & value: */
  2445. s = scheme_char_string_to_byte_string(argv[1]);
  2446. scheme_arg_mismatch(scheme_symbol_val(argv[0]),
  2447. SCHEME_BYTE_STR_VAL(s),
  2448. argv[2]);
  2449. } else {
  2450. /* Multiple strings & values: */
  2451. char *st, **ss;
  2452. intptr_t slen, *slens, total = 0;
  2453. int offset = (mismatch ? 0 : 1);
  2454. int scount = argc - 1 - offset;
  2455. ss = (char **)MALLOC_N(char*, scount);
  2456. slens = (intptr_t *)MALLOC_N_ATOMIC(intptr_t, scount);
  2457. for (i = 1; (i + offset) < argc; i++) {
  2458. if (i & 1) {
  2459. s = scheme_char_string_to_byte_string(argv[i+offset]);
  2460. st = SCHEME_BYTE_STR_VAL(s);
  2461. slen = SCHEME_BYTE_STRLEN_VAL(s);
  2462. if (!mismatch)
  2463. total += 5;
  2464. } else {
  2465. s = argv[i+offset];
  2466. if (SAME_TYPE(SCHEME_TYPE(s), scheme_unquoted_printing_string_type)) {
  2467. s = SCHEME_PTR_VAL(s);
  2468. s = scheme_char_string_to_byte_string(s);
  2469. st = SCHEME_BYTE_STR_VAL(s);
  2470. slen = SCHEME_BYTE_STRLEN_VAL(s);
  2471. } else {
  2472. st = scheme_make_provided_string(s, scount / 2, &slen);
  2473. }
  2474. }
  2475. total += slen;
  2476. ss[i-1] = st;
  2477. slens[i-1] = slen;
  2478. }
  2479. st = (char *)scheme_malloc_atomic(total + 1);
  2480. total = 0;
  2481. for (i = 0; i < scount; i++) {
  2482. slen = slens[i];
  2483. if (!mismatch && !(i & 1)) {
  2484. memcpy(st + total, "\n ", 3);
  2485. total += 3;
  2486. }
  2487. memcpy(st + total, ss[i], slen);
  2488. total += slen;
  2489. if (!mismatch && !(i & 1)) {
  2490. memcpy(st + total, ": ", 2);
  2491. total += 2;
  2492. }
  2493. }
  2494. st[total] = 0;
  2495. s = scheme_char_string_to_byte_string(argv[1]);
  2496. if (mismatch) {
  2497. s2 = "";
  2498. l2 = 0;
  2499. } else {
  2500. s2 = SCHEME_BYTE_STR_VAL(s);
  2501. l2 = SCHEME_BYTE_STRLEN_VAL(s);
  2502. }
  2503. scheme_raise_exn(MZEXN_FAIL_CONTRACT,
  2504. "%s: %t%t",
  2505. scheme_symbol_val(argv[0]),
  2506. s2, l2,
  2507. st, total);
  2508. }
  2509. return NULL;
  2510. }
  2511. static Scheme_Object *raise_mismatch_error(int argc, Scheme_Object *argv[])
  2512. {
  2513. return do_raise_mismatch_error("raise-mismatch-error", 1, argc, argv);
  2514. }
  2515. static Scheme_Object *raise_arguments_error(int argc, Scheme_Object *argv[])
  2516. {
  2517. return do_raise_mismatch_error("raise-arguments-error", 0, argc, argv);
  2518. }
  2519. static int is_arity_at_least(Scheme_Object *v)
  2520. {
  2521. return (SCHEME_CHAPERONE_STRUCTP(v)
  2522. && scheme_is_struct_instance(scheme_arity_at_least, v)
  2523. && scheme_nonneg_exact_p(((Scheme_Structure *)v)->slots[0]));
  2524. }
  2525. static int is_arity_list(Scheme_Object *l)
  2526. {
  2527. int c;
  2528. Scheme_Object *a;
  2529. c = scheme_proper_list_length(l);
  2530. if (c < 0) return 0;
  2531. while (!SCHEME_NULLP(l)) {
  2532. a = SCHEME_CAR(l);
  2533. if (!scheme_nonneg_exact_p(a)
  2534. && !is_arity_at_least(a))
  2535. return 0;
  2536. l = SCHEME_CDR(l);
  2537. }
  2538. return 1;
  2539. }
  2540. static Scheme_Object *do_raise_arity_error(const char *who, int argc, Scheme_Object *argv[], int as_arity)
  2541. {
  2542. Scheme_Object **args, *arity;
  2543. const char *name;
  2544. int minc, maxc;
  2545. if (!SCHEME_SYMBOLP(argv[0]) && !SCHEME_PROCP(argv[0]))
  2546. scheme_wrong_contract(who, "(or/c symbol? procedure?)", 0, argc, argv);
  2547. if (as_arity) {
  2548. arity = argv[1];
  2549. if (!scheme_nonneg_exact_p(arity)
  2550. && !is_arity_at_least(arity)
  2551. && !is_arity_list(arity))
  2552. scheme_wrong_contract(who,
  2553. "(or/c exact-nonnegative-integer? arity-at-least? (listof (or/c exact-nonnegative-integer? arity-at-least?)))",
  2554. 1, argc, argv);
  2555. } else {
  2556. if (!scheme_exact_p(argv[1]))
  2557. scheme_wrong_contract(who,
  2558. "exact-integer?",
  2559. 1, argc, argv);
  2560. arity = scheme_arity_mask_to_arity(argv[1], -1);
  2561. }
  2562. args = MALLOC_N(Scheme_Object*, argc - 2);
  2563. memcpy(args, argv + 2, sizeof(Scheme_Object*) * (argc - 2));
  2564. if (SCHEME_SYMBOLP(argv[0]))
  2565. name = scheme_symbol_val(argv[0]);
  2566. else {
  2567. int len;
  2568. name = scheme_get_proc_name(argv[0], &len, 1);
  2569. }
  2570. if (SCHEME_INTP(arity)) {
  2571. minc = maxc = SCHEME_INT_VAL(arity);
  2572. } else if (is_arity_at_least(arity)) {
  2573. Scheme_Object *v;
  2574. v = scheme_struct_ref(arity, 0);
  2575. if (SCHEME_INTP(v)) {
  2576. minc = SCHEME_INT_VAL(v);
  2577. maxc = -1;
  2578. } else {
  2579. minc = -2;
  2580. maxc = 0;
  2581. }
  2582. } else {
  2583. minc = -2;
  2584. maxc = 0;
  2585. }
  2586. scheme_wrong_count_m(name, minc, maxc, argc - 2, args, 0);
  2587. return NULL;
  2588. }
  2589. static Scheme_Object *raise_arity_error(int argc, Scheme_Object *argv[])
  2590. {
  2591. return do_raise_arity_error("raise-arity-error", argc, argv, 1);
  2592. }
  2593. static Scheme_Object *raise_arity_mask_error(int argc, Scheme_Object *argv[])
  2594. {
  2595. return do_raise_arity_error("raise-arity-mask-error", argc, argv, 0);
  2596. }
  2597. static Scheme_Object *raise_result_arity_error(int argc, Scheme_Object *argv[])
  2598. {
  2599. const char *where = NULL, *detail = NULL;
  2600. Scheme_Object **got_argv;
  2601. int i, expected;
  2602. if (SCHEME_FALSEP(argv[0]))
  2603. where = NULL;
  2604. else if (SCHEME_SYMBOLP(argv[0]))
  2605. where = scheme_symbol_val(argv[0]);
  2606. else
  2607. scheme_wrong_contract("raise-result-arity-error", "(or/c symbol? #f)", 0, argc, argv);
  2608. if (SCHEME_INTP(argv[1])) {
  2609. expected = SCHEME_INT_VAL(argv[1]);
  2610. } else if (SCHEME_BIGNUMP(argv[1]) && SCHEME_BIGPOS(argv[1]))
  2611. expected = (int)(((unsigned)-1) >> 1); /* not right, but as big as we can report */
  2612. else
  2613. expected = -1;
  2614. if (expected < 0)
  2615. scheme_wrong_contract("raise-result-arity-error", "exact-nonnegative-integer?", 1, argc, argv);
  2616. if (SCHEME_FALSEP(argv[2]))
  2617. detail = NULL;
  2618. else if (SCHEME_CHAR_STRINGP(argv[2])) {
  2619. Scheme_Object *bstr;
  2620. bstr = scheme_char_string_to_byte_string(argv[2]);
  2621. detail = SCHEME_BYTE_STR_VAL(bstr);
  2622. } else
  2623. scheme_wrong_contract("raise-result-arity-error", "(or/c string? #f)", 2, argc, argv);
  2624. got_argv = MALLOC_N(Scheme_Object*, argc-3);
  2625. for (i = 3; i < argc; i++) {
  2626. got_argv[i-3] = argv[i];
  2627. }
  2628. scheme_wrong_return_arity(where, expected,
  2629. argc-3, got_argv,
  2630. (detail ? "%s" : NULL), detail,
  2631. NULL);
  2632. return scheme_void;
  2633. }
  2634. static Scheme_Object *good_print_width(int c, Scheme_Object **argv)
  2635. {
  2636. int ok;
  2637. ok = (SCHEME_INTP(argv[0])
  2638. ? (SCHEME_INT_VAL(argv[0]) >= 3)
  2639. : (SCHEME_BIGNUMP(argv[0])
  2640. ? SCHEME_BIGPOS(argv[0])
  2641. : 0));
  2642. return ok ? scheme_true : scheme_false;
  2643. }
  2644. static Scheme_Object *error_print_width(int argc, Scheme_Object *argv[])
  2645. {
  2646. return scheme_param_config2("error-print-width",
  2647. scheme_make_integer(MZCONFIG_ERROR_PRINT_WIDTH),
  2648. argc, argv,
  2649. -1, good_print_width, "(and/c exact-integer? (>=/c 3))", 0);
  2650. }
  2651. static Scheme_Object *good_print_context_length(int c, Scheme_Object **argv)
  2652. {
  2653. int ok;
  2654. ok = (SCHEME_INTP(argv[0])
  2655. ? (SCHEME_INT_VAL(argv[0]) >= 0)
  2656. : (SCHEME_BIGNUMP(argv[0])
  2657. ? SCHEME_BIGPOS(argv[0])
  2658. : 0));
  2659. return ok ? scheme_true : scheme_false;
  2660. }
  2661. static Scheme_Object *error_print_context_length(int argc, Scheme_Object *argv[])
  2662. {
  2663. return scheme_param_config2("error-print-context-length",
  2664. scheme_make_integer(MZCONFIG_ERROR_PRINT_CONTEXT_LENGTH),
  2665. argc, argv,
  2666. -1, good_print_context_length, "exact-nonnegative-integer?", 0);
  2667. }
  2668. static Scheme_Object *error_print_srcloc(int argc, Scheme_Object *argv[])
  2669. {
  2670. return scheme_param_config("error-print-source-location",
  2671. scheme_make_integer(MZCONFIG_ERROR_PRINT_SRCLOC),
  2672. argc, argv,
  2673. -1, NULL, NULL, 1);
  2674. }
  2675. void scheme_write_proc_context(Scheme_Object *port, int print_width,
  2676. Scheme_Object *name,
  2677. Scheme_Object *src, Scheme_Object *line,
  2678. Scheme_Object *col, Scheme_Object *pos,
  2679. int generated)
  2680. {
  2681. if (src) {
  2682. scheme_display_w_max(src, port, print_width);
  2683. if (line && SCHEME_TRUEP(line)) {
  2684. /* Line + column */
  2685. scheme_write_byte_string(":", 1, port);
  2686. scheme_display_w_max(line, port, print_width);
  2687. scheme_write_byte_string(":", 1, port);
  2688. scheme_display_w_max(col, port, print_width);
  2689. } else if (pos && SCHEME_TRUEP(pos)) {
  2690. /* Position */
  2691. scheme_write_byte_string("::", 2, port);
  2692. scheme_display_w_max(pos, port, print_width);
  2693. }
  2694. if (SCHEME_TRUEP(name)) {
  2695. scheme_write_byte_string(": ", 2, port);
  2696. }
  2697. }
  2698. if (SCHEME_TRUEP(name)) {
  2699. scheme_display_w_max(name, port, print_width);
  2700. }
  2701. }
  2702. static void write_context_repeats(int repeats, Scheme_Object *port)
  2703. {
  2704. char buf[64];
  2705. sprintf(buf, "[repeats %d more time%s]", repeats, (repeats == 1) ? "" : "s");
  2706. scheme_write_byte_string(buf, strlen(buf), port);
  2707. }
  2708. static Scheme_Object *
  2709. def_error_display_proc(int argc, Scheme_Object *argv[])
  2710. {
  2711. Scheme_Config *config;
  2712. Scheme_Object *port, *s;
  2713. config = scheme_current_config();
  2714. port = scheme_get_param(config, MZCONFIG_ERROR_PORT);
  2715. if (!SCHEME_CHAR_STRINGP(argv[0]))
  2716. scheme_wrong_contract("default-error-display-handler", "string?", 0, argc, argv);
  2717. /* don't care about argv[1] */
  2718. s = scheme_char_string_to_byte_string(argv[0]);
  2719. scheme_write_byte_string(SCHEME_BYTE_STR_VAL(s),
  2720. SCHEME_BYTE_STRTAG_VAL(s),
  2721. port);
  2722. /* Print context, if available */
  2723. if (SCHEME_CHAPERONE_STRUCTP(argv[1])
  2724. && scheme_is_struct_instance(exn_table[MZEXN].type, argv[1])
  2725. && !scheme_is_struct_instance(exn_table[MZEXN_FAIL_USER].type, argv[1])) {
  2726. Scheme_Object *l, *w;
  2727. int print_width = 1024, max_cnt = 16;
  2728. w = scheme_get_param(config, MZCONFIG_ERROR_PRINT_CONTEXT_LENGTH);
  2729. if (SCHEME_INTP(w))
  2730. max_cnt = SCHEME_INT_VAL(w);
  2731. else
  2732. max_cnt = 0x7FFFFFFF;
  2733. if (max_cnt) {
  2734. Scheme_Object *prev_name;
  2735. int orig_max_cnt = max_cnt, repeats;
  2736. w = scheme_get_param(config, MZCONFIG_ERROR_PRINT_WIDTH);
  2737. if (SCHEME_INTP(w))
  2738. print_width = SCHEME_INT_VAL(w);
  2739. else
  2740. print_width = 0x7FFFFFFF;
  2741. /* Print srcloc(s) if present */
  2742. l = scheme_struct_type_property_ref(scheme_source_property, argv[1]);
  2743. if (l)
  2744. l = _scheme_apply(l, 1, &(argv[1]));
  2745. if (l && !SCHEME_NULLP(l)) {
  2746. /* Some exns include srcloc in the msg, so skip the first srcloc of those when needed */
  2747. if (SCHEME_TRUEP(scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PRINT_SRCLOC))
  2748. && (scheme_is_struct_instance(exn_table[MZEXN_FAIL_READ].type, argv[1])
  2749. || scheme_is_struct_instance(exn_table[MZEXN_FAIL_CONTRACT_VARIABLE].type, argv[1])))
  2750. l = SCHEME_CDR(l);
  2751. if (!SCHEME_NULLP(l))
  2752. scheme_write_byte_string("\n location...:", 15, port);
  2753. while (!SCHEME_NULLP(l)) {
  2754. scheme_write_byte_string("\n ", 4, port);
  2755. w = SCHEME_CAR(l);
  2756. w = srcloc_to_string(1, &w);
  2757. scheme_display_w_max(w, port, print_width);
  2758. l = SCHEME_CDR(l);
  2759. }
  2760. }
  2761. prev_name = NULL;
  2762. repeats = 0;
  2763. l = scheme_get_stack_trace(scheme_struct_ref(argv[1], 1));
  2764. while (!SCHEME_NULLP(l)) {
  2765. if (!max_cnt) {
  2766. scheme_write_byte_string("\n ...", 7, port);
  2767. break;
  2768. } else {
  2769. Scheme_Object *name, *loc;
  2770. name = SCHEME_CAR(l);
  2771. if (prev_name && scheme_equal(name, prev_name)) {
  2772. repeats++;
  2773. } else {
  2774. if (max_cnt == orig_max_cnt) {
  2775. /* Starting label: */
  2776. scheme_write_byte_string("\n context...:\n", 15, port);
  2777. } else {
  2778. scheme_write_byte_string("\n", 1, port);
  2779. }
  2780. if (repeats) {
  2781. scheme_write_byte_string(" ", 3, port);
  2782. write_context_repeats(repeats, port);
  2783. repeats = 0;
  2784. --max_cnt;
  2785. if (max_cnt)
  2786. scheme_write_byte_string("\n", 1, port);
  2787. }
  2788. prev_name = name;
  2789. if (max_cnt) {
  2790. loc = SCHEME_CDR(name);
  2791. name = SCHEME_CAR(name);
  2792. scheme_write_byte_string(" ", 3, port);
  2793. if (SCHEME_TRUEP(loc)) {
  2794. Scheme_Structure *sloc = (Scheme_Structure *)loc;
  2795. scheme_write_proc_context(port, print_width,
  2796. name,
  2797. sloc->slots[0], sloc->slots[1],
  2798. sloc->slots[2], sloc->slots[3],
  2799. 0);
  2800. } else {
  2801. scheme_write_proc_context(port, print_width,
  2802. name,
  2803. NULL, NULL, NULL, NULL,
  2804. 0);
  2805. }
  2806. --max_cnt;
  2807. }
  2808. }
  2809. l = SCHEME_CDR(l);
  2810. }
  2811. }
  2812. if (repeats) {
  2813. scheme_write_byte_string("\n", 1, port);
  2814. scheme_write_byte_string(" ", 3, port);
  2815. write_context_repeats(repeats, port);
  2816. }
  2817. }
  2818. }
  2819. scheme_write_byte_string("\n", 1, port);
  2820. return scheme_void;
  2821. }
  2822. static Scheme_Object *
  2823. emergency_error_display_proc(int argc, Scheme_Object *argv[])
  2824. {
  2825. Scheme_Object *s;
  2826. if (!SCHEME_CHAR_STRINGP(argv[0]))
  2827. return scheme_void;
  2828. s = scheme_char_string_to_byte_string(argv[0]);
  2829. scheme_log_message(NULL, SCHEME_LOG_ERROR,
  2830. SCHEME_BYTE_STR_VAL(s), SCHEME_BYTE_STRTAG_VAL(s),
  2831. scheme_false);
  2832. return scheme_void;
  2833. }
  2834. static Scheme_Object *
  2835. def_error_value_string_proc(int argc, Scheme_Object *argv[])
  2836. {
  2837. intptr_t origl, len, l;
  2838. char *s;
  2839. Scheme_Object *pph;
  2840. if (!SCHEME_INTP(argv[1]))
  2841. scheme_wrong_contract("default-error-value->string-handler", "number?", 1, argc, argv);
  2842. origl = len = SCHEME_INT_VAL(argv[1]);
  2843. pph = scheme_get_param(scheme_current_config(), MZCONFIG_PORT_PRINT_HANDLER);
  2844. if (SAME_OBJ(pph, scheme_default_global_print_handler)) {
  2845. if (len < 3)
  2846. len = 3;
  2847. s = scheme_print_to_string_w_max(argv[0], &l, len);
  2848. if ((origl < 3) && (l > origl))
  2849. l = origl;
  2850. } else {
  2851. Scheme_Object *a[2];
  2852. a[0] = argv[0];
  2853. a[1] = scheme_make_byte_string_output_port();
  2854. _scheme_apply(pph, 2, a);
  2855. s = scheme_get_sized_byte_string_output(a[1], &l);
  2856. if (l > origl) {
  2857. /* FIXME: might hit the middle of a UTF-8 encoding. */
  2858. l = origl;
  2859. if (origl >= 1) {
  2860. s[origl - 1] = '.';
  2861. if (origl >= 2) {
  2862. s[origl - 2] = '.';
  2863. if (origl >= 3)
  2864. s[origl - 3] = '.';
  2865. }
  2866. }
  2867. }
  2868. }
  2869. return scheme_make_sized_utf8_string(s, l);
  2870. }
  2871. static MZ_NORETURN void
  2872. def_error_escape_proc(int argc, Scheme_Object *argv[])
  2873. {
  2874. Scheme_Object *prompt;
  2875. Scheme_Thread *p = scheme_current_thread;
  2876. prompt = scheme_extract_one_cc_mark(NULL, SCHEME_PTR_VAL(scheme_default_prompt_tag));
  2877. if (prompt) {
  2878. p->cjs.jumping_to_continuation = prompt;
  2879. p->cjs.alt_full_continuation = NULL;
  2880. p->cjs.num_vals = 1;
  2881. p->cjs.val = scheme_void_proc;
  2882. }
  2883. scheme_longjmp(scheme_error_buf, 1);
  2884. }
  2885. static Scheme_Object *
  2886. error_display_handler(int argc, Scheme_Object *argv[])
  2887. {
  2888. return scheme_param_config("error-display-handler",
  2889. scheme_make_integer(MZCONFIG_ERROR_DISPLAY_HANDLER),
  2890. argc, argv,
  2891. 2, NULL, NULL, 0);
  2892. }
  2893. static Scheme_Object *
  2894. error_value_string_handler(int argc, Scheme_Object *argv[])
  2895. {
  2896. return scheme_param_config("error-value->string-handler",
  2897. scheme_make_integer(MZCONFIG_ERROR_PRINT_VALUE_HANDLER),
  2898. argc, argv,
  2899. 2, NULL, NULL, 0);
  2900. }
  2901. static Scheme_Object *
  2902. error_escape_handler(int argc, Scheme_Object *argv[])
  2903. {
  2904. return scheme_param_config("error-escape-handler",
  2905. scheme_make_integer(MZCONFIG_ERROR_ESCAPE_HANDLER),
  2906. argc, argv,
  2907. 0, NULL, NULL, 0);
  2908. }
  2909. static Scheme_Object *
  2910. exit_handler(int argc, Scheme_Object *argv[])
  2911. {
  2912. return scheme_param_config("exit-handler",
  2913. scheme_make_integer(MZCONFIG_EXIT_HANDLER),
  2914. argc, argv,
  2915. 1, NULL, NULL, 0);
  2916. }
  2917. static Scheme_Object *
  2918. def_exit_handler_proc(int argc, Scheme_Object *argv[])
  2919. {
  2920. intptr_t status;
  2921. if (SCHEME_INTP(argv[0])) {
  2922. status = SCHEME_INT_VAL(argv[0]);
  2923. if (status < 1 || status > 255)
  2924. status = 0;
  2925. } else
  2926. status = 0;
  2927. scheme_flush_managed(NULL, 0);
  2928. if (scheme_exit)
  2929. scheme_exit(status);
  2930. else
  2931. exit(status);
  2932. return scheme_void;
  2933. }
  2934. Scheme_Object *
  2935. scheme_do_exit(int argc, Scheme_Object *argv[])
  2936. {
  2937. intptr_t status;
  2938. Scheme_Object *handler;
  2939. if (argc == 1) {
  2940. if (SCHEME_INTP(argv[0]))
  2941. status = SCHEME_INT_VAL(argv[0]);
  2942. else
  2943. status = 0;
  2944. } else
  2945. status = 0;
  2946. handler = scheme_get_param(scheme_current_config(), MZCONFIG_EXIT_HANDLER);
  2947. if (handler) {
  2948. Scheme_Object *p[1];
  2949. p[0] = argc ? argv[0] : scheme_make_integer(status);
  2950. scheme_apply_multi(handler, 1, p);
  2951. } else if (scheme_exit)
  2952. scheme_exit(status);
  2953. else
  2954. exit(status);
  2955. return scheme_void;
  2956. }
  2957. /* scheme_immediate_exit ensures that a call to exit() goes to the C
  2958. library used by the Racket DLL, and not some other copy of the
  2959. library (in Windows) */
  2960. void scheme_immediate_exit(int status)
  2961. {
  2962. exit(status);
  2963. }
  2964. static Scheme_Object *
  2965. exe_yield_handler(int argc, Scheme_Object *argv[])
  2966. {
  2967. return scheme_param_config("exeuctable-yield-handler",
  2968. scheme_make_integer(MZCONFIG_EXE_YIELD_HANDLER),
  2969. argc, argv,
  2970. 1, NULL, NULL, 0);
  2971. }
  2972. static Scheme_Object *default_yield_handler(int argc, Scheme_Object **argv)
  2973. {
  2974. return scheme_void;
  2975. }
  2976. /***********************************************************************/
  2977. static Scheme_Object *level_number_to_symbol(int level)
  2978. {
  2979. switch (level) {
  2980. case 0:
  2981. return scheme_false;
  2982. break;
  2983. case SCHEME_LOG_FATAL:
  2984. return fatal_symbol;
  2985. break;
  2986. case SCHEME_LOG_ERROR:
  2987. return error_symbol;
  2988. break;
  2989. case SCHEME_LOG_WARNING:
  2990. return warning_symbol;
  2991. break;
  2992. case SCHEME_LOG_INFO:
  2993. return info_symbol;
  2994. break;
  2995. case SCHEME_LOG_DEBUG:
  2996. default:
  2997. return debug_symbol;
  2998. break;
  2999. }
  3000. }
  3001. static int extract_spec_level(Scheme_Object *level_spec, Scheme_Object *name)
  3002. {
  3003. if (!level_spec) return 0;
  3004. while (1) {
  3005. if (SCHEME_INTP(level_spec))
  3006. return SCHEME_INT_VAL(level_spec);
  3007. else if (name && SAME_OBJ(SCHEME_CADR(level_spec), name))
  3008. return SCHEME_INT_VAL(SCHEME_CAR(level_spec));
  3009. level_spec = SCHEME_CDR(SCHEME_CDR(level_spec));
  3010. }
  3011. }
  3012. static int extract_max_spec_level(Scheme_Object *level_spec, Scheme_Object *name)
  3013. {
  3014. int mx = 0, v;
  3015. if (name)
  3016. return extract_spec_level(level_spec, name);
  3017. if (level_spec) {
  3018. while (1) {
  3019. if (SCHEME_INTP(level_spec)) {
  3020. v = SCHEME_INT_VAL(level_spec);
  3021. if (v > mx) mx = v;
  3022. break;
  3023. } else {
  3024. v = SCHEME_INT_VAL(SCHEME_CAR(level_spec));
  3025. if (v > mx) mx = v;
  3026. level_spec = SCHEME_CDR(SCHEME_CDR(level_spec));
  3027. }
  3028. }
  3029. }
  3030. return mx;
  3031. }
  3032. void update_want_level(Scheme_Logger *logger, Scheme_Object *name)
  3033. {
  3034. Scheme_Log_Reader *lr;
  3035. Scheme_Object *queue, *b, *prev;
  3036. Scheme_Logger *parent = logger;
  3037. int want_level, level, ceiling_level = SCHEME_LOG_DEBUG;
  3038. want_level = 0;
  3039. while (parent) {
  3040. queue = parent->readers;
  3041. prev = NULL;
  3042. while (queue) {
  3043. b = SCHEME_CAR(queue);
  3044. b = SCHEME_CAR(b);
  3045. lr = (Scheme_Log_Reader *)SCHEME_BOX_VAL(b);
  3046. if (lr) {
  3047. level = extract_max_spec_level(lr->level, name);
  3048. if (level > ceiling_level)
  3049. level = ceiling_level;
  3050. if (level > want_level)
  3051. want_level = level;
  3052. if (want_level >= ceiling_level)
  3053. break;
  3054. prev = queue;
  3055. } else {
  3056. if (prev)
  3057. SCHEME_CDR(prev) = SCHEME_CDR(queue);
  3058. else
  3059. parent->readers = SCHEME_CDR(queue);
  3060. }
  3061. queue = SCHEME_CDR(queue);
  3062. }
  3063. level = extract_max_spec_level(parent->syslog_level, name);
  3064. if (level > want_level)
  3065. want_level = level;
  3066. level = extract_max_spec_level(parent->stderr_level, name);
  3067. if (level > want_level)
  3068. want_level = level;
  3069. level = extract_max_spec_level(parent->stdout_level, name);
  3070. if (level > want_level)
  3071. want_level = level;
  3072. if (parent->propagate_level)
  3073. level = extract_max_spec_level(parent->propagate_level, name);
  3074. else
  3075. level = SCHEME_LOG_DEBUG;
  3076. if (level <= ceiling_level)
  3077. ceiling_level = level;
  3078. if (want_level >= ceiling_level)
  3079. break;
  3080. parent = parent->parent;
  3081. }
  3082. if (!name) {
  3083. logger->want_level = want_level;
  3084. logger->local_timestamp = SCHEME_INT_VAL(logger->root_timestamp[0]);
  3085. } else {
  3086. # define WANT_NAME_LEVEL_CACHE_SIZE 8
  3087. int i;
  3088. b = logger->want_name_level_cache;
  3089. if (!b) {
  3090. b = scheme_make_vector(3 * WANT_NAME_LEVEL_CACHE_SIZE, scheme_make_integer(-1));
  3091. logger->want_name_level_cache = b;
  3092. }
  3093. /* find a slot already matching this name? */
  3094. for (i = SCHEME_VEC_SIZE(b); (i -= 3) >= 0; ) {
  3095. if (SAME_OBJ(name, SCHEME_VEC_ELS(b)[i]))
  3096. break;
  3097. }
  3098. if (i == 0) abort();
  3099. if (i < 0) {
  3100. /* find an out-of-date slot? */
  3101. for (i = SCHEME_VEC_SIZE(b); (i -= 3) >= 0; ) {
  3102. if (SCHEME_INT_VAL(SCHEME_VEC_ELS(b)[i+1]) < SCHEME_INT_VAL(logger->root_timestamp[0]))
  3103. break;
  3104. }
  3105. if (i < 0) {
  3106. /* rotate cache */
  3107. i = 3 * (WANT_NAME_LEVEL_CACHE_SIZE - 1);
  3108. memmove(&(SCHEME_VEC_ELS(b)[0]),
  3109. &(SCHEME_VEC_ELS(b)[3]),
  3110. i * sizeof(Scheme_Object *));
  3111. }
  3112. }
  3113. SCHEME_VEC_ELS(b)[i] = name;
  3114. SCHEME_VEC_ELS(b)[i+1] = scheme_make_integer(SCHEME_INT_VAL(logger->root_timestamp[0]));
  3115. SCHEME_VEC_ELS(b)[i+2] = scheme_make_integer(want_level);
  3116. }
  3117. }
  3118. static int get_want_level(Scheme_Logger *logger, Scheme_Object *name)
  3119. {
  3120. if (name && SCHEME_TRUEP(name)) {
  3121. while (1) {
  3122. if (logger->want_name_level_cache) {
  3123. int i;
  3124. for (i = SCHEME_VEC_SIZE(logger->want_name_level_cache); (i -= 3) >= 0; ) {
  3125. if (SAME_OBJ(name, SCHEME_VEC_ELS(logger->want_name_level_cache)[i])) {
  3126. if (SCHEME_INT_VAL(SCHEME_VEC_ELS(logger->want_name_level_cache)[i+1]) == SCHEME_INT_VAL(logger->root_timestamp[0])) {
  3127. return SCHEME_INT_VAL(SCHEME_VEC_ELS(logger->want_name_level_cache)[i+2]);
  3128. }
  3129. }
  3130. }
  3131. }
  3132. update_want_level(logger, name);
  3133. }
  3134. } else {
  3135. if (logger->local_timestamp < SCHEME_INT_VAL(logger->root_timestamp[0]))
  3136. update_want_level(logger, NULL);
  3137. return logger->want_level;
  3138. }
  3139. }
  3140. int scheme_log_level_topic_p(Scheme_Logger *logger, int level, Scheme_Object *name)
  3141. {
  3142. if (!logger) {
  3143. Scheme_Config *config;
  3144. config = scheme_current_config();
  3145. logger = (Scheme_Logger *)scheme_get_param(config, MZCONFIG_LOGGER);
  3146. }
  3147. if (!name) {
  3148. if (logger->local_timestamp < SCHEME_INT_VAL(logger->root_timestamp[0]))
  3149. update_want_level(logger, NULL);
  3150. return (logger->want_level >= level);
  3151. } else {
  3152. int want_level;
  3153. want_level = get_want_level(logger, name);
  3154. return (want_level >= level);
  3155. }
  3156. }
  3157. int scheme_log_level_p(Scheme_Logger *logger, int level)
  3158. {
  3159. return scheme_log_level_topic_p(logger, level, NULL);
  3160. }
  3161. Scheme_Object *extract_all_levels(Scheme_Logger *logger)
  3162. {
  3163. Scheme_Hash_Table *names;
  3164. Scheme_Log_Reader *lr;
  3165. Scheme_Object *queue, *b, *name, *result = scheme_null, *l;
  3166. int level, default_level;
  3167. Scheme_Logger *parent = logger;
  3168. names = scheme_make_hash_table(SCHEME_hash_ptr);
  3169. default_level = get_want_level(logger, scheme_void);
  3170. while (parent) {
  3171. queue = parent->readers;
  3172. while (queue) {
  3173. b = SCHEME_CAR(queue);
  3174. b = SCHEME_CAR(b);
  3175. lr = (Scheme_Log_Reader *)SCHEME_BOX_VAL(b);
  3176. if (lr) {
  3177. for (l = lr->level; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
  3178. l = SCHEME_CDR(l);
  3179. name = SCHEME_CAR(l);
  3180. if (!SCHEME_SYM_WEIRDP(name) && !scheme_hash_get(names, name)) {
  3181. level = get_want_level(logger, name);
  3182. scheme_hash_set(names, name, scheme_true);
  3183. if (level != default_level) {
  3184. result = scheme_make_pair(level_number_to_symbol(level),
  3185. scheme_make_pair(name, result));
  3186. }
  3187. }
  3188. SCHEME_USE_FUEL(1);
  3189. }
  3190. }
  3191. queue = SCHEME_CDR(queue);
  3192. }
  3193. parent = parent->parent;
  3194. SCHEME_USE_FUEL(1);
  3195. }
  3196. result = scheme_make_pair(level_number_to_symbol(default_level),
  3197. scheme_make_pair(scheme_false, result));
  3198. return result;
  3199. }
  3200. static Scheme_Object *make_log_message(int level, Scheme_Object *name, int prefix_msg,
  3201. char *buffer, intptr_t len, Scheme_Object *data) {
  3202. Scheme_Object *msg;
  3203. Scheme_Object *v;
  3204. msg = scheme_make_vector(4, NULL);
  3205. v = level_number_to_symbol(level);
  3206. SCHEME_VEC_ELS(msg)[0] = v;
  3207. if (name && prefix_msg) {
  3208. /* Add logger name prefix: */
  3209. intptr_t slen;
  3210. char *cp;
  3211. slen = SCHEME_SYM_LEN(name);
  3212. cp = scheme_malloc_atomic(slen + 2 + len + 1);
  3213. memcpy(cp, SCHEME_SYM_VAL(name), slen);
  3214. memcpy(cp + slen, ": ", 2);
  3215. memcpy(cp + slen + 2, buffer, len + 1);
  3216. len += slen + 2;
  3217. buffer = cp;
  3218. }
  3219. v = scheme_make_sized_utf8_string(buffer, len);
  3220. SCHEME_SET_CHAR_STRING_IMMUTABLE(v);
  3221. SCHEME_VEC_ELS(msg)[1] = v;
  3222. SCHEME_VEC_ELS(msg)[2] = (data ? data : scheme_false);
  3223. SCHEME_VEC_ELS(msg)[3] = (name ? name : scheme_false);
  3224. SCHEME_SET_VECTOR_IMMUTABLE(msg);
  3225. return msg;
  3226. }
  3227. void scheme_log_name_pfx_message(Scheme_Logger *logger, int level, Scheme_Object *name,
  3228. char *buffer, intptr_t len, Scheme_Object *data,
  3229. int prefix_msg)
  3230. {
  3231. /* This function must avoid GC allocation when called with the
  3232. configuration of scheme_log_abort(). */
  3233. Scheme_Object *queue, *q, *msg = NULL, *b;
  3234. Scheme_Log_Reader *lr;
  3235. if (!logger) {
  3236. Scheme_Config *config;
  3237. config = scheme_current_config();
  3238. logger = (Scheme_Logger *)scheme_get_param(config, MZCONFIG_LOGGER);
  3239. }
  3240. if (logger->local_timestamp < SCHEME_INT_VAL(logger->root_timestamp[0]))
  3241. update_want_level(logger, NULL);
  3242. if (logger->want_level < level)
  3243. return;
  3244. if (!name)
  3245. name = logger->name;
  3246. if (SCHEME_FALSEP(name))
  3247. name = NULL;
  3248. while (logger) {
  3249. if (extract_spec_level(logger->syslog_level, name) >= level) {
  3250. int pri;
  3251. Scheme_Object *cmd;
  3252. switch (level) {
  3253. case SCHEME_LOG_FATAL:
  3254. pri = RKTIO_LOG_FATAL;
  3255. break;
  3256. case SCHEME_LOG_ERROR:
  3257. pri = RKTIO_LOG_ERROR;
  3258. break;
  3259. case SCHEME_LOG_WARNING:
  3260. pri = RKTIO_LOG_WARNING;
  3261. break;
  3262. case SCHEME_LOG_INFO:
  3263. pri = RKTIO_LOG_INFO;
  3264. break;
  3265. case SCHEME_LOG_DEBUG:
  3266. default:
  3267. pri = RKTIO_LOG_DEBUG;
  3268. break;
  3269. }
  3270. cmd = scheme_get_run_cmd();
  3271. rktio_syslog(scheme_rktio, pri,
  3272. (name ? SCHEME_SYM_VAL(name) : NULL),
  3273. buffer, SCHEME_PATH_VAL(cmd));
  3274. }
  3275. if (extract_spec_level(logger->stderr_level, name) >= level) {
  3276. if (name && prefix_msg) {
  3277. intptr_t slen;
  3278. slen = SCHEME_SYM_LEN(name);
  3279. fwrite(SCHEME_SYM_VAL(name), slen, 1, stderr);
  3280. fwrite(": ", 2, 1, stderr);
  3281. }
  3282. fwrite(buffer, len, 1, stderr);
  3283. fwrite("\n", 1, 1, stderr);
  3284. }
  3285. if (extract_spec_level(logger->stdout_level, name) >= level) {
  3286. if (name && prefix_msg) {
  3287. intptr_t slen;
  3288. slen = SCHEME_SYM_LEN(name);
  3289. fwrite(SCHEME_SYM_VAL(name), slen, 1, stdout);
  3290. fwrite(": ", 2, 1, stdout);
  3291. }
  3292. fwrite(buffer, len, 1, stdout);
  3293. fwrite("\n", 1, 1, stdout);
  3294. fflush(stdout);
  3295. }
  3296. queue = logger->readers;
  3297. while (queue) {
  3298. b = SCHEME_CAR(queue);
  3299. b = SCHEME_CAR(b);
  3300. lr = (Scheme_Log_Reader *)SCHEME_BOX_VAL(b);
  3301. if (lr) {
  3302. if (extract_spec_level(lr->level, name) >= level) {
  3303. if (!msg)
  3304. msg = make_log_message(level, name, prefix_msg, buffer, len, data);
  3305. /* enqueue */
  3306. q = scheme_make_raw_pair(msg, NULL);
  3307. if (lr->tail)
  3308. SCHEME_CDR(lr->tail) = q;
  3309. else
  3310. lr->head = q;
  3311. lr->tail = q;
  3312. scheme_post_sema(lr->sema);
  3313. }
  3314. }
  3315. queue = SCHEME_CDR(queue);
  3316. }
  3317. if (logger->parent && logger->propagate_level) {
  3318. if (extract_spec_level(logger->propagate_level, name) < level)
  3319. break;
  3320. }
  3321. logger = logger->parent;
  3322. }
  3323. }
  3324. void scheme_log_name_message(Scheme_Logger *logger, int level, Scheme_Object *name,
  3325. char *buffer, intptr_t len, Scheme_Object *data)
  3326. {
  3327. scheme_log_name_pfx_message(logger, level, name, buffer, len, data, 1);
  3328. }
  3329. void scheme_log_message(Scheme_Logger *logger, int level, char *buffer, intptr_t len, Scheme_Object *data)
  3330. {
  3331. scheme_log_name_pfx_message(logger, level, NULL, buffer, len, data, 1);
  3332. }
  3333. void scheme_log_abort(char *buffer)
  3334. {
  3335. Scheme_Logger logger;
  3336. Scheme_Object *ts[2];
  3337. memset(&logger, 0, sizeof(logger));
  3338. logger.name = NULL;
  3339. logger.parent = NULL;
  3340. logger.want_level = SCHEME_LOG_FATAL;
  3341. ts[0] = scheme_make_integer(0);
  3342. ts[1] = NULL;
  3343. logger.root_timestamp = ts;
  3344. logger.local_timestamp = 0;
  3345. logger.syslog_level = init_syslog_level;
  3346. logger.stderr_level = init_stderr_level;
  3347. logger.stdout_level = init_stdout_level;
  3348. scheme_log_message(&logger, SCHEME_LOG_FATAL, buffer, strlen(buffer), scheme_false);
  3349. }
  3350. void scheme_log_warning(char *buffer)
  3351. {
  3352. scheme_log_message(scheme_main_logger, SCHEME_LOG_WARNING, buffer, strlen(buffer), scheme_false);
  3353. }
  3354. static void glib_log_message(const char *log_domain,
  3355. int log_level,
  3356. const char *message,
  3357. void *user_data)
  3358. /* in the main thread for some place */
  3359. {
  3360. #define mzG_LOG_LEVEL_ERROR (1 << 2)
  3361. #define mzG_LOG_LEVEL_CRITICAL (1 << 3)
  3362. #define mzG_LOG_LEVEL_WARNING (1 << 4)
  3363. #define mzG_LOG_LEVEL_MESSAGE (1 << 5)
  3364. #define mzG_LOG_LEVEL_INFO (1 << 6)
  3365. #define mzG_LOG_LEVEL_DEBUG (1 << 7)
  3366. int level, len1, len2;
  3367. char *together;
  3368. if (log_level & (mzG_LOG_LEVEL_ERROR))
  3369. level = SCHEME_LOG_FATAL;
  3370. else if (log_level & (mzG_LOG_LEVEL_CRITICAL))
  3371. level = SCHEME_LOG_ERROR;
  3372. else if (log_level & (mzG_LOG_LEVEL_WARNING | mzG_LOG_LEVEL_MESSAGE))
  3373. level = SCHEME_LOG_WARNING;
  3374. else if (log_level & (mzG_LOG_LEVEL_INFO))
  3375. level = SCHEME_LOG_INFO;
  3376. else /* if (log_level & (mzG_LOG_LEVEL_DEBUG)) */
  3377. level = SCHEME_LOG_DEBUG;
  3378. len2 = strlen(message);
  3379. if (log_domain) {
  3380. len1 = strlen(log_domain);
  3381. together = (char *)scheme_malloc_atomic(len1 + len2 + 3);
  3382. memcpy(together, log_domain, len1);
  3383. memcpy(together + len1, ": ", 2);
  3384. memcpy(together + len1 + 2, message, len2);
  3385. len2 += len1 + 2;
  3386. } else
  3387. together = (char *)message;
  3388. scheme_log_message(scheme_main_logger, level, together, len2, scheme_false);
  3389. }
  3390. void scheme_glib_log_message(const char *log_domain,
  3391. int log_level,
  3392. const char *message,
  3393. void *user_data)
  3394. XFORM_SKIP_PROC
  3395. /* This handler is suitable for use as a glib logging handler.
  3396. Although a handler can be implemented with the FFI,
  3397. we build one into Racket to avoid potential problems of
  3398. handlers getting GCed or retaining a namespace. */
  3399. {
  3400. if (scheme_is_place_main_os_thread())
  3401. glib_log_message(log_domain, log_level, message, user_data);
  3402. else {
  3403. /* We're in an unknown thread. Queue the message for the main Racket place's thread. */
  3404. #ifdef MZ_USE_MZRT
  3405. glib_log_queue_entry *e = malloc(sizeof(glib_log_queue_entry));
  3406. e->log_domain = strdup(log_domain);
  3407. e->log_level = log_level;
  3408. e->message = strdup(message);
  3409. mzrt_mutex_lock(glib_log_queue_lock);
  3410. e->next = glib_log_queue;
  3411. glib_log_queue = e;
  3412. mzrt_mutex_unlock(glib_log_queue_lock);
  3413. scheme_signal_received_at(glib_log_signal_handle);
  3414. #else
  3415. /* We shouldn't get here, but just in case: */
  3416. fprintf(stderr, "%s: %s\n", log_domain, message);
  3417. #endif
  3418. }
  3419. }
  3420. /* For use by testing, suitable for use with pthread_create, logs a
  3421. warning for ";"-separated messages in `str` */
  3422. void *scheme_glib_log_message_test(char *str)
  3423. XFORM_SKIP_PROC
  3424. {
  3425. int i;
  3426. for (i = 0; str[i]; i++) {
  3427. if (str[i] == ';') {
  3428. str[i] = 0;
  3429. scheme_glib_log_message("test", mzG_LOG_LEVEL_WARNING, str, NULL);
  3430. str[i] = ';';
  3431. str = str + i + 1;
  3432. i = 0;
  3433. }
  3434. }
  3435. scheme_glib_log_message("test", mzG_LOG_LEVEL_WARNING, str, NULL);
  3436. return NULL;
  3437. }
  3438. #ifdef MZ_USE_MZRT
  3439. void scheme_init_glib_log_queue(void)
  3440. {
  3441. mzrt_mutex_create(&glib_log_queue_lock);
  3442. glib_log_signal_handle = scheme_get_signal_handle();
  3443. }
  3444. void scheme_check_glib_log_messages(void)
  3445. {
  3446. if (scheme_current_place_id == 0) {
  3447. glib_log_queue_entry *e, *prev = NULL, *next;
  3448. mzrt_mutex_lock(glib_log_queue_lock);
  3449. e = glib_log_queue;
  3450. glib_log_queue = NULL;
  3451. mzrt_mutex_unlock(glib_log_queue_lock);
  3452. if (e) {
  3453. /* Reverse list */
  3454. while (e->next) {
  3455. next = e->next;
  3456. e->next = prev;
  3457. prev = e;
  3458. e = next;
  3459. }
  3460. e->next = prev;
  3461. /* Process messages */
  3462. for (; e; e = e->next) {
  3463. glib_log_message(e->log_domain, e->log_level, e->message, NULL);
  3464. }
  3465. /* In case a thread is blocked waiting for a log event */
  3466. scheme_signal_received_at(glib_log_signal_handle);
  3467. }
  3468. }
  3469. }
  3470. #endif
  3471. static int extract_level(const char *who, int none_ok, int which, int argc, Scheme_Object **argv)
  3472. {
  3473. Scheme_Object *v;
  3474. int level;
  3475. v = argv[which];
  3476. if (SAME_OBJ(v, none_symbol))
  3477. level = 0;
  3478. else if (SAME_OBJ(v, fatal_symbol))
  3479. level = SCHEME_LOG_FATAL;
  3480. else if (SAME_OBJ(v, error_symbol))
  3481. level = SCHEME_LOG_ERROR;
  3482. else if (SAME_OBJ(v, warning_symbol))
  3483. level = SCHEME_LOG_WARNING;
  3484. else if (SAME_OBJ(v, info_symbol))
  3485. level = SCHEME_LOG_INFO;
  3486. else if (SAME_OBJ(v, debug_symbol))
  3487. level = SCHEME_LOG_DEBUG;
  3488. else {
  3489. scheme_wrong_contract(who,
  3490. (none_ok
  3491. ? "(or/c 'none 'fatal 'error 'warning 'info 'debug)"
  3492. : "(or/c 'fatal 'error 'warning 'info 'debug)"),
  3493. which, argc, argv);
  3494. return 0;
  3495. }
  3496. return level;
  3497. }
  3498. static Scheme_Object *
  3499. log_message(int argc, Scheme_Object *argv[])
  3500. {
  3501. Scheme_Logger *logger;
  3502. Scheme_Object *bytes;
  3503. Scheme_Object *name;
  3504. Scheme_Object *data;
  3505. int level, pos, pfx;
  3506. if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_logger_type))
  3507. scheme_wrong_contract("log-message", "logger?", 0, argc, argv);
  3508. logger = (Scheme_Logger *)argv[0];
  3509. level = extract_level("log-message", 0, 1, argc, argv);
  3510. pos = 2;
  3511. if (SCHEME_SYMBOLP(argv[pos]) || SCHEME_FALSEP(argv[pos]))
  3512. name = argv[pos++];
  3513. else
  3514. name = NULL;
  3515. bytes = argv[pos];
  3516. if (!SCHEME_CHAR_STRINGP(bytes))
  3517. scheme_wrong_contract("log-message", "string?", pos, argc, argv);
  3518. bytes = scheme_char_string_to_byte_string(bytes);
  3519. pos++;
  3520. if (argc > (pos+1))
  3521. pfx = SCHEME_TRUEP(argv[pos+1]);
  3522. else
  3523. pfx = 1;
  3524. if (pos >= argc)
  3525. data = scheme_false;
  3526. else
  3527. data = argv[pos];
  3528. scheme_log_name_pfx_message(logger, level, name,
  3529. SCHEME_BYTE_STR_VAL(bytes), SCHEME_BYTE_STRLEN_VAL(bytes), data,
  3530. pfx);
  3531. return scheme_void;
  3532. }
  3533. static Scheme_Object *
  3534. log_level_p(int argc, Scheme_Object *argv[])
  3535. {
  3536. Scheme_Logger *logger;
  3537. Scheme_Object *name = scheme_false;
  3538. int level, want_level;
  3539. if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_logger_type))
  3540. scheme_wrong_contract("log-level?", "logger?", 0, argc, argv);
  3541. logger = (Scheme_Logger *)argv[0];
  3542. level = extract_level("log-level?", 0, 1, argc, argv);
  3543. if (argc > 2) {
  3544. if (!SCHEME_FALSEP(argv[2]) && !SCHEME_SYMBOLP(argv[2]))
  3545. scheme_wrong_contract("log-level?", "(or/c f? #symbol)", 2, argc, argv);
  3546. name = argv[2];
  3547. }
  3548. want_level = get_want_level(logger, name);
  3549. return ((want_level >= level) ? scheme_true : scheme_false);
  3550. }
  3551. static Scheme_Object *
  3552. log_max_level(int argc, Scheme_Object *argv[])
  3553. {
  3554. Scheme_Logger *logger;
  3555. Scheme_Object *name = scheme_false;
  3556. if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_logger_type))
  3557. scheme_wrong_contract("log-max-level", "logger?", 0, argc, argv);
  3558. logger = (Scheme_Logger *)argv[0];
  3559. if (argc > 1) {
  3560. if (!SCHEME_FALSEP(argv[1]) && !SCHEME_SYMBOLP(argv[1]))
  3561. scheme_wrong_contract("log-max-level", "(or/c f? #symbol)", 1, argc, argv);
  3562. name = argv[1];
  3563. }
  3564. return level_number_to_symbol(get_want_level(logger, name));
  3565. }
  3566. static Scheme_Object *
  3567. log_all_levels(int argc, Scheme_Object *argv[])
  3568. {
  3569. Scheme_Logger *logger;
  3570. if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_logger_type))
  3571. scheme_wrong_contract("log-all-levels", "logger?", 0, argc, argv);
  3572. logger = (Scheme_Logger *)argv[0];
  3573. return extract_all_levels(logger);
  3574. }
  3575. static Scheme_Object *
  3576. log_level_evt(int argc, Scheme_Object *argv[])
  3577. {
  3578. Scheme_Logger *logger;
  3579. Scheme_Object *sema;
  3580. if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_logger_type))
  3581. scheme_wrong_contract("log-level-evt", "logger?", 0, argc, argv);
  3582. logger = (Scheme_Logger *)argv[0];
  3583. sema = logger->root_timestamp[1];
  3584. if (!sema) {
  3585. sema = scheme_make_sema(0);
  3586. logger->root_timestamp[1] = sema;
  3587. }
  3588. return scheme_make_sema_repost(sema);
  3589. }
  3590. static Scheme_Object *get_levels_and_names(const char *who, int i, int argc, Scheme_Object **argv,
  3591. int default_lvl)
  3592. {
  3593. int lvl;
  3594. Scheme_Object *level = scheme_null, *last = NULL;
  3595. for (; i < argc; i += 2) {
  3596. lvl = extract_level(who, 1, i, argc, argv);
  3597. if ((i+1) < argc) {
  3598. if (SCHEME_FALSEP(argv[i+1]))
  3599. default_lvl = lvl;
  3600. else {
  3601. if (!SCHEME_SYMBOLP(argv[i+1]))
  3602. scheme_wrong_contract(who, "(or/c symbol? #f)", i+1, argc, argv);
  3603. level = scheme_make_pair(argv[i+1], level);
  3604. if (!last) last = level;
  3605. level = scheme_make_pair(scheme_make_integer(lvl), level);
  3606. }
  3607. } else {
  3608. default_lvl = lvl;
  3609. }
  3610. }
  3611. if (last)
  3612. SCHEME_CDR(last) = scheme_make_integer(default_lvl);
  3613. else
  3614. level = scheme_make_integer(default_lvl);
  3615. return level;
  3616. }
  3617. static Scheme_Object *
  3618. make_logger(int argc, Scheme_Object *argv[])
  3619. {
  3620. Scheme_Logger *parent, *logger;
  3621. Scheme_Object *propagate_level;
  3622. if (argc) {
  3623. if (!SCHEME_FALSEP(argv[0]) && !SCHEME_SYMBOLP(argv[0]))
  3624. scheme_wrong_contract("make-logger", "(or/c symbol? #f)", 0, argc, argv);
  3625. if (argc > 1) {
  3626. if (SCHEME_FALSEP(argv[1]))
  3627. parent = NULL;
  3628. else {
  3629. if (!SAME_TYPE(SCHEME_TYPE(argv[1]), scheme_logger_type))
  3630. scheme_wrong_contract("make-logger", "(or/c logger? #f)", 1, argc, argv);
  3631. parent = (Scheme_Logger *)argv[1];
  3632. }
  3633. } else
  3634. parent = NULL;
  3635. } else
  3636. parent = NULL;
  3637. propagate_level = get_levels_and_names("make-logger", 2, argc, argv,
  3638. SCHEME_LOG_DEBUG);
  3639. logger = scheme_make_logger(parent,
  3640. (argc
  3641. ? (SCHEME_FALSEP(argv[0]) ? NULL : argv[0])
  3642. : NULL));
  3643. if (parent)
  3644. logger->propagate_level = propagate_level;
  3645. return (Scheme_Object *)logger;
  3646. }
  3647. Scheme_Logger *scheme_make_logger(Scheme_Logger *parent, Scheme_Object *name)
  3648. {
  3649. Scheme_Logger *logger;
  3650. logger = MALLOC_ONE_TAGGED(Scheme_Logger);
  3651. logger->so.type = scheme_logger_type;
  3652. logger->parent = parent;
  3653. if (parent) {
  3654. logger->root_timestamp = parent->root_timestamp;
  3655. } else {
  3656. Scheme_Object **root_timestamp;
  3657. root_timestamp = MALLOC_N(Scheme_Object*, 2);
  3658. root_timestamp[0] = scheme_make_integer(1);
  3659. logger->root_timestamp = root_timestamp;
  3660. }
  3661. logger->name = name;
  3662. return logger;
  3663. }
  3664. static Scheme_Object *
  3665. logger_p(int argc, Scheme_Object *argv[])
  3666. {
  3667. return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_logger_type)
  3668. ? scheme_true
  3669. : scheme_false);
  3670. }
  3671. static Scheme_Object *
  3672. current_logger(int argc, Scheme_Object *argv[])
  3673. {
  3674. return scheme_param_config2("current-logger",
  3675. scheme_make_integer(MZCONFIG_LOGGER),
  3676. argc, argv,
  3677. -1, logger_p, "logger?", 0);
  3678. }
  3679. static Scheme_Object *
  3680. logger_name(int argc, Scheme_Object *argv[])
  3681. {
  3682. Scheme_Object *name;
  3683. if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_logger_type))
  3684. scheme_wrong_contract("logger-name", "logger?", 0, argc, argv);
  3685. name = ((Scheme_Logger *)argv[0])->name;
  3686. return (name ? name : scheme_false);
  3687. }
  3688. static Scheme_Object *
  3689. make_log_reader(int argc, Scheme_Object *argv[])
  3690. {
  3691. Scheme_Logger *logger;
  3692. Scheme_Log_Reader *lr;
  3693. Scheme_Object *sema, *q;
  3694. Scheme_Object *level;
  3695. if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_logger_type))
  3696. scheme_wrong_contract("make-log-receiver", "logger?", 0, argc, argv);
  3697. logger = (Scheme_Logger *)argv[0];
  3698. level = get_levels_and_names("make-log-receiver", 1, argc, argv, 0);
  3699. lr = MALLOC_ONE_TAGGED(Scheme_Log_Reader);
  3700. lr->so.type = scheme_log_reader_type;
  3701. lr->level = level;
  3702. sema = scheme_make_sema(0);
  3703. lr->sema = sema;
  3704. /* Pair a weak reference to the reader with a strong reference to the
  3705. channel. Channel gets are wrapped to reference the reader. That way,
  3706. the link is effectively strong while a thread is sync'd on the
  3707. reader. */
  3708. q = scheme_make_raw_pair(scheme_make_pair(scheme_make_weak_box((Scheme_Object *)lr),
  3709. sema),
  3710. logger->readers);
  3711. logger->readers = q;
  3712. logger->root_timestamp[0] = scheme_make_integer(SCHEME_INT_VAL(logger->root_timestamp[0]) + 1);
  3713. if (logger->root_timestamp[1]) {
  3714. scheme_post_sema_all(logger->root_timestamp[1]);
  3715. logger->root_timestamp[1] = NULL;
  3716. }
  3717. return (Scheme_Object *)lr;
  3718. }
  3719. static Scheme_Object *
  3720. log_reader_p(int argc, Scheme_Object *argv[])
  3721. {
  3722. return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_log_reader_type)
  3723. ? scheme_true
  3724. : scheme_false);
  3725. }
  3726. static Scheme_Object *dequeue_log(Scheme_Object *_lr)
  3727. {
  3728. Scheme_Log_Reader *lr = (Scheme_Log_Reader *)_lr;
  3729. if (lr->head) {
  3730. Scheme_Object *v;
  3731. v = SCHEME_CAR(lr->head);
  3732. lr->head = SCHEME_CDR(lr->head);
  3733. if (!lr->head)
  3734. lr->tail = NULL;
  3735. return v;
  3736. } else {
  3737. scheme_signal_error("empty log-reader queue!?");
  3738. return NULL;
  3739. }
  3740. }
  3741. static int log_reader_get(Scheme_Object *_lr, Scheme_Schedule_Info *sinfo)
  3742. {
  3743. Scheme_Log_Reader *lr = (Scheme_Log_Reader *)_lr;
  3744. scheme_set_sync_target(sinfo, lr->sema, (Scheme_Object *)lr, NULL, 0, 1, dequeue_log);
  3745. return 0;
  3746. }
  3747. /***********************************************************************/
  3748. void
  3749. scheme_raise_exn(int id, ...)
  3750. {
  3751. GC_CAN_IGNORE va_list args;
  3752. intptr_t alen;
  3753. char *msg;
  3754. int i, c, unsupported = 0;
  3755. Scheme_Object *eargs[MZEXN_MAXARGS], *errno_val = NULL;
  3756. char *buffer;
  3757. rktio_remap_last_error(scheme_rktio);
  3758. /* Precise GC: Don't allocate before getting hidden args off stack */
  3759. HIDE_FROM_XFORM(va_start(args, id));
  3760. if (id == MZEXN_OTHER)
  3761. c = 3;
  3762. else
  3763. c = exn_table[id].args;
  3764. for (i = 2; i < c; i++) {
  3765. eargs[i] = mzVA_ARG(args, Scheme_Object*);
  3766. }
  3767. msg = mzVA_ARG(args, char*);
  3768. alen = sch_vsprintf(NULL, 0, msg, args, &buffer, &errno_val, &unsupported);
  3769. HIDE_FROM_XFORM(va_end(args));
  3770. eargs[0] = scheme_make_immutable_sized_utf8_string(buffer, alen);
  3771. eargs[1] = TMP_CMARK_VALUE;
  3772. if (errno_val) {
  3773. if (id == MZEXN_FAIL_FILESYSTEM) {
  3774. id = MZEXN_FAIL_FILESYSTEM_ERRNO;
  3775. eargs[2] = errno_val;
  3776. c++;
  3777. } else if (id == MZEXN_FAIL_NETWORK) {
  3778. id = MZEXN_FAIL_NETWORK_ERRNO;
  3779. eargs[2] = errno_val;
  3780. c++;
  3781. }
  3782. } else if (unsupported) {
  3783. if (id == MZEXN_FAIL)
  3784. id = MZEXN_FAIL_UNSUPPORTED;
  3785. }
  3786. do_raise(scheme_make_struct_instance(exn_table[id].type,
  3787. c, eargs),
  3788. 1,
  3789. 1);
  3790. }
  3791. static MZ_NORETURN void
  3792. def_exn_handler(int argc, Scheme_Object *argv[])
  3793. {
  3794. char *s;
  3795. intptr_t len = -1;
  3796. if (SCHEME_CHAPERONE_STRUCTP(argv[0])
  3797. && scheme_is_struct_instance(exn_table[MZEXN].type, argv[0])) {
  3798. Scheme_Object *str;
  3799. str = scheme_struct_ref(argv[0], 0);
  3800. if (SCHEME_CHAR_STRINGP(str)) {
  3801. str = scheme_char_string_to_byte_string(str);
  3802. s = SCHEME_BYTE_STR_VAL(str);
  3803. len = SCHEME_BYTE_STRTAG_VAL(str);
  3804. } else
  3805. s = "exception raised [message field is not a string]";
  3806. } else {
  3807. char *v;
  3808. v = scheme_make_provided_string(argv[0], 1, &len);
  3809. s = scheme_malloc_atomic(len + 21);
  3810. memcpy(s, "uncaught exception: ", 20);
  3811. memcpy(s + 20, v, len + 1);
  3812. len += 20;
  3813. }
  3814. call_error(s, len, argv[0]);
  3815. }
  3816. static Scheme_Object *
  3817. init_exn_handler(int argc, Scheme_Object *argv[])
  3818. {
  3819. return scheme_param_config("uncaught-exception-handler",
  3820. scheme_make_integer(MZCONFIG_INIT_EXN_HANDLER),
  3821. argc, argv,
  3822. 1, NULL, NULL, 0);
  3823. }
  3824. static MZ_NORETURN void
  3825. nested_exn_handler(void *old_exn, int argc, Scheme_Object *argv[])
  3826. {
  3827. Scheme_Object *arg = argv[0], *orig_arg = SCHEME_CDR((Scheme_Object *)old_exn);
  3828. intptr_t len, mlen = -1, orig_mlen = -1, blen;
  3829. char *buffer, *msg, *orig_msg, *raisetype, *orig_raisetype, *who, *sep;
  3830. buffer = init_buf(&len, &blen);
  3831. if (SCHEME_FALSEP(SCHEME_CAR((Scheme_Object *)old_exn))) {
  3832. raisetype = "";
  3833. sep = "";
  3834. who = "handler for uncaught exceptions";
  3835. msg = "did not escape";
  3836. } else {
  3837. who = SCHEME_BYTE_STR_VAL(SCHEME_CAR((Scheme_Object *)old_exn));
  3838. sep = " by ";
  3839. if (SCHEME_CHAPERONE_STRUCTP(arg)
  3840. && scheme_is_struct_instance(exn_table[MZEXN].type, arg)) {
  3841. Scheme_Object *str;
  3842. str = scheme_struct_ref(arg, 0);
  3843. raisetype = "exception raised";
  3844. str = scheme_char_string_to_byte_string(str);
  3845. msg = SCHEME_BYTE_STR_VAL(str);
  3846. mlen = SCHEME_BYTE_STRLEN_VAL(str);
  3847. } else {
  3848. msg = error_write_to_string_w_max(arg, len, NULL);
  3849. raisetype = "raise called (with non-exception value)";
  3850. }
  3851. }
  3852. if (SCHEME_CHAPERONE_STRUCTP(orig_arg)
  3853. && scheme_is_struct_instance(exn_table[MZEXN].type, orig_arg)) {
  3854. Scheme_Object *str;
  3855. str = scheme_struct_ref(orig_arg, 0);
  3856. orig_raisetype = "exception raised";
  3857. str = scheme_char_string_to_byte_string(str);
  3858. orig_msg = SCHEME_BYTE_STR_VAL(str);
  3859. orig_mlen = SCHEME_BYTE_STRLEN_VAL(str);
  3860. } else {
  3861. orig_msg = error_write_to_string_w_max(orig_arg, len, NULL);
  3862. orig_raisetype = "raise called (with non-exception value)";
  3863. }
  3864. blen = scheme_sprintf(buffer, blen, "%s%s%s: %t; original %s: %t",
  3865. raisetype, sep, who,
  3866. msg, mlen,
  3867. orig_raisetype,
  3868. orig_msg, orig_mlen);
  3869. call_error(buffer, blen, scheme_false);
  3870. }
  3871. static MZ_NORETURN void *do_raise_inside_barrier(void)
  3872. {
  3873. Scheme_Object *arg;
  3874. Scheme_Object *v, *p[1], *h, *marks;
  3875. Scheme_Cont_Mark_Chain *chain;
  3876. Scheme_Cont_Frame_Data cframe, cframe2;
  3877. int got_chain;
  3878. arg = scheme_current_thread->ku.k.p1;
  3879. scheme_current_thread->ku.k.p1 = NULL;
  3880. h = scheme_extract_one_cc_mark(NULL, scheme_exn_handler_key);
  3881. chain = NULL;
  3882. got_chain = 0;
  3883. while (1) {
  3884. if (!h) {
  3885. h = scheme_get_param(scheme_current_config(), MZCONFIG_INIT_EXN_HANDLER);
  3886. chain = NULL;
  3887. got_chain = 1;
  3888. }
  3889. v = scheme_make_byte_string_without_copying("exception handler");
  3890. v = scheme_make_closed_prim_w_arity((Scheme_Closed_Prim *)nested_exn_handler,
  3891. scheme_make_pair(v, arg),
  3892. "nested-exception-handler",
  3893. 1, 1);
  3894. scheme_push_continuation_frame(&cframe);
  3895. scheme_set_cont_mark(scheme_exn_handler_key, v);
  3896. scheme_push_break_enable(&cframe2, 0, 0);
  3897. p[0] = arg;
  3898. v = _scheme_apply(h, 1, p);
  3899. scheme_pop_break_enable(&cframe2, 0);
  3900. scheme_pop_continuation_frame(&cframe);
  3901. /* Getting a value back means that we should chain to the
  3902. next exception handler; we supply the returned value to
  3903. the next exception handler (if any). */
  3904. if (!got_chain) {
  3905. marks = scheme_all_current_continuation_marks();
  3906. chain = ((Scheme_Cont_Mark_Set *)marks)->chain;
  3907. marks = NULL;
  3908. /* Init chain to position of the handler we just
  3909. called. */
  3910. while (chain->key != scheme_exn_handler_key) {
  3911. chain = chain->next;
  3912. }
  3913. got_chain = 1;
  3914. }
  3915. if (chain) {
  3916. chain = chain->next;
  3917. while (chain && (chain->key != scheme_exn_handler_key)) {
  3918. chain = chain->next;
  3919. }
  3920. if (!chain)
  3921. h = NULL; /* use uncaught handler */
  3922. else
  3923. h = chain->val;
  3924. arg = v;
  3925. } else {
  3926. /* return from uncaught-exception handler */
  3927. p[0] = scheme_false;
  3928. nested_exn_handler(scheme_make_pair(scheme_false, arg), 1, p);
  3929. #ifndef MZ_PRECISE_RETURN_SPEC
  3930. return NULL;
  3931. #endif
  3932. }
  3933. }
  3934. }
  3935. static void
  3936. do_raise(Scheme_Object *arg, int need_debug, int eb)
  3937. {
  3938. Scheme_Thread *p = scheme_current_thread;
  3939. if (p->constant_folding) {
  3940. if (p->constant_folding != (Optimize_Info *)scheme_false) {
  3941. const char *msg;
  3942. if (need_debug) {
  3943. msg = scheme_display_to_string(((Scheme_Structure *)arg)->slots[0], NULL);
  3944. } else
  3945. msg = scheme_print_to_string(arg, NULL);
  3946. scheme_log(scheme_optimize_info_logger(p->constant_folding),
  3947. SCHEME_LOG_WARNING,
  3948. 0,
  3949. "warning%s: constant-fold attempt failed: %s",
  3950. scheme_optimize_info_context(p->constant_folding),
  3951. msg);
  3952. }
  3953. if (SCHEME_CHAPERONE_STRUCTP(arg)
  3954. && scheme_is_struct_instance(exn_table[MZEXN_BREAK].type, arg)) {
  3955. /* remember to re-raise exception */
  3956. scheme_current_thread->reading_delayed = arg;
  3957. }
  3958. scheme_longjmp (scheme_error_buf, 1);
  3959. }
  3960. if (need_debug) {
  3961. Scheme_Object *marks;
  3962. marks = scheme_current_continuation_marks(NULL);
  3963. ((Scheme_Structure *)arg)->slots[1] = marks;
  3964. }
  3965. p->ku.k.p1 = arg;
  3966. if (eb) {
  3967. scheme_top_level_do(do_raise_inside_barrier, 1);
  3968. MZ_UNREACHABLE;
  3969. }
  3970. else
  3971. do_raise_inside_barrier();
  3972. }
  3973. static MZ_NORETURN void
  3974. sch_raise(int argc, Scheme_Object *argv[])
  3975. {
  3976. if ((argc > 1) && SCHEME_FALSEP(argv[1]))
  3977. do_raise(argv[0], 0, 0);
  3978. else
  3979. do_raise(argv[0], 0, 1);
  3980. }
  3981. void scheme_raise(Scheme_Object *exn)
  3982. {
  3983. do_raise(exn, 0, 1);
  3984. }
  3985. typedef Scheme_Object (*Scheme_Struct_Field_Guard_Proc)(int argc, Scheme_Object *v);
  3986. static Scheme_Object *exn_field_check(int argc, Scheme_Object **argv)
  3987. {
  3988. Scheme_Object *a[2], *v;
  3989. if (!SCHEME_CHAR_STRINGP(argv[0]))
  3990. scheme_wrong_field_contract(argv[2], "string?", argv[0]);
  3991. if (!SAME_OBJ(argv[1], TMP_CMARK_VALUE) && !SCHEME_CONT_MARK_SETP(argv[1]))
  3992. scheme_wrong_field_contract(argv[2], "continuation-mark-set?", argv[1]);
  3993. a[0] = argv[0];
  3994. a[1] = argv[1];
  3995. if (!SCHEME_IMMUTABLE_CHAR_STRINGP(a[0])) {
  3996. v = scheme_make_immutable_sized_char_string(SCHEME_CHAR_STR_VAL(a[0]),
  3997. SCHEME_CHAR_STRLEN_VAL(a[0]),
  3998. 1);
  3999. a[0] = v;
  4000. }
  4001. return scheme_values(2, a);
  4002. }
  4003. static Scheme_Object *variable_field_check(int argc, Scheme_Object **argv)
  4004. {
  4005. if (!SCHEME_SYMBOLP(argv[2]))
  4006. scheme_wrong_field_contract(argv[3], "symbol?", argv[2]);
  4007. return scheme_values(3, argv);
  4008. }
  4009. static Scheme_Object *read_field_check(int argc, Scheme_Object **argv)
  4010. {
  4011. Scheme_Object *l;
  4012. l = argv[2];
  4013. while (SCHEME_PAIRP(l)) {
  4014. if (!scheme_is_location(SCHEME_CAR(l)))
  4015. break;
  4016. l = SCHEME_CDR(l);
  4017. }
  4018. if (!SCHEME_NULLP(l))
  4019. scheme_wrong_field_contract(argv[3], "(listof srcloc?)", argv[2]);
  4020. return scheme_values(3, argv);
  4021. }
  4022. static Scheme_Object *break_field_check(int argc, Scheme_Object **argv)
  4023. {
  4024. if (!SCHEME_ECONTP(argv[2]))
  4025. scheme_wrong_field_contract(argv[3], "escape-continuation?", argv[2]);
  4026. return scheme_values(3, argv);
  4027. }
  4028. static Scheme_Object *errno_field_check(int argc, Scheme_Object **argv)
  4029. {
  4030. if (!SCHEME_PAIRP(argv[2])
  4031. || !scheme_exact_p(SCHEME_CAR(argv[2]))
  4032. || !(SAME_OBJ(SCHEME_CDR(argv[2]), posix_symbol)
  4033. || SAME_OBJ(SCHEME_CDR(argv[2]), windows_symbol)
  4034. || SAME_OBJ(SCHEME_CDR(argv[2]), gai_symbol)))
  4035. scheme_wrong_field_contract(argv[3], "(cons/c exact-integer? (or/c 'posix 'windows 'gai))", argv[2]);
  4036. return scheme_values (3, argv);
  4037. }
  4038. static Scheme_Object *extract_read_locations(int argc, Scheme_Object **argv)
  4039. {
  4040. if (scheme_is_struct_instance(exn_table[MZEXN_FAIL_READ].type, argv[0]))
  4041. return scheme_struct_ref(argv[0], 2);
  4042. scheme_wrong_contract("exn:fail:read-locations-accessor", "exn:fail:read?", 0, argc, argv);
  4043. return NULL;
  4044. }
  4045. void scheme_init_exn(Scheme_Startup_Env *env)
  4046. {
  4047. int i, j;
  4048. Scheme_Object *tmpo, **tmpop;
  4049. #define _MZEXN_DECL_FIELDS
  4050. # include "schexn.h"
  4051. #undef _MZEXN_DECL_FIELDS
  4052. #define _MZEXN_DECL_PROPS
  4053. # include "schexn.h"
  4054. #undef _MZEXN_DECL_PROPS
  4055. REGISTER_SO(exn_table);
  4056. #ifdef MEMORY_COUNTING_ON
  4057. # ifndef GLOBAL_EXN_TABLE
  4058. scheme_misc_count += (sizeof(exn_rec) * MZEXN_OTHER);
  4059. # endif
  4060. #endif
  4061. #define _MZEXN_PRESETUP
  4062. # include "schexn.h"
  4063. #undef _MZEXN_PRESETUP
  4064. #define EXN_PARENT(id) exn_table[id].type
  4065. #define EXN_FLAGS (SCHEME_STRUCT_EXPTIME | SCHEME_STRUCT_NO_SET | SCHEME_STRUCT_NO_MAKE_PREFIX)
  4066. #define SETUP_STRUCT(id, parent, name, argc, args, props, guard) \
  4067. { tmpo = scheme_make_struct_type_from_string(name, parent, argc, props, guard, 1); \
  4068. exn_table[id].type = tmpo; \
  4069. tmpop = scheme_make_struct_names_from_array(name, argc, args, EXN_FLAGS, &exn_table[id].count); \
  4070. exn_table[id].names = tmpop; }
  4071. #define EXNCONS scheme_make_pair
  4072. #define _MZEXN_SETUP
  4073. #include "schexn.h"
  4074. for (i = 0; i < MZEXN_OTHER; i++) {
  4075. if (exn_table[i].count) {
  4076. Scheme_Object **values;
  4077. scheme_force_struct_type_info((Scheme_Struct_Type *)exn_table[i].type);
  4078. values = scheme_make_struct_values(exn_table[i].type,
  4079. exn_table[i].names,
  4080. exn_table[i].count,
  4081. EXN_FLAGS);
  4082. for (j = exn_table[i].count - 1; j--; ) {
  4083. scheme_addto_primitive_instance_by_symbol(exn_table[i].names[j],
  4084. values[j],
  4085. env);
  4086. }
  4087. }
  4088. }
  4089. scheme_addto_prim_instance("uncaught-exception-handler",
  4090. scheme_register_parameter(init_exn_handler,
  4091. "uncaught-exception-handler",
  4092. MZCONFIG_INIT_EXN_HANDLER),
  4093. env);
  4094. scheme_addto_prim_instance("raise",
  4095. scheme_make_noncm_prim((Scheme_Prim *)sch_raise,
  4096. "raise",
  4097. 1, 2),
  4098. env);
  4099. }
  4100. void scheme_init_exn_config(void)
  4101. {
  4102. Scheme_Object *h;
  4103. h = scheme_make_prim_w_arity((Scheme_Prim *)def_exn_handler, "default-exception-handler", 1, 1);
  4104. scheme_set_root_param(MZCONFIG_INIT_EXN_HANDLER, h);
  4105. }