1 /* This file contains a restructed Racket reader for reading startup
2 code and for ".zo" files. The normal reader is a recursive-descent
3 parser. The really messy part is number parsing, which is in a
4 different file, "numstr.c".
5
6 Rule on using scheme_ungetc(): the reader is generally allowed to
7 use scheme_ungetc() only when it will definitely re-read the
8 character as it continues. If the character will not be re-read
9 (e.g., because an exception will be raised), then the reader must
10 peek, instead. However, read-symbol uses ungetc() if the port does
11 not have a specific peek handler, and in that case, read-symbol
12 only ungetc()s a single character (that had been read by itself). */
13
14 #include "schpriv.h"
15 #include "schmach.h"
16 #include "schminc.h"
17 #include "schcpt.h"
18 #include "racket_version.h"
19 #include <stdlib.h>
20 #include <ctype.h>
21 #ifdef USE_STACKAVAIL
22 # include <malloc.h>
23 #endif
24
25 #ifdef __clang__
26 # ifdef MZ_PRECISE_GC
27 # pragma clang diagnostic ignored "-Wself-assign"
28 # endif
29 #endif
30
31 #define MAX_QUICK_SYMBOL_SIZE 64
32
33 /* Init options for embedding: */
34 /* these are used to set initial config parameterizations */
35 SHARED_OK int scheme_square_brackets_are_parens = 1;
36 SHARED_OK int scheme_curly_braces_are_parens = 1;
37 /* global flag set from environment variable */
38 SHARED_OK static int use_perma_cache = 1;
39 SHARED_OK static int validate_loaded_linklet = 0;
40
41 THREAD_LOCAL_DECL(int scheme_num_read_syntax_objects = 0);
42
43 /* read-only global symbols */
44 SHARED_OK static unsigned char delim[128];
45 SHARED_OK static unsigned char cpt_branch[256];
46
47 /* Table of built-in variable refs for .zo loading: */
48 SHARED_OK static Scheme_Object **variable_references;
49 SHARED_OK int unsafe_variable_references_start;
50
51 ROSYM static Scheme_Object *quote_symbol;
52 ROSYM static Scheme_Object *quasiquote_symbol;
53 ROSYM static Scheme_Object *unquote_symbol;
54 ROSYM static Scheme_Object *unquote_splicing_symbol;
55 ROSYM static Scheme_Object *syntax_symbol;
56 ROSYM static Scheme_Object *unsyntax_symbol;
57 ROSYM static Scheme_Object *unsyntax_splicing_symbol;
58 ROSYM static Scheme_Object *quasisyntax_symbol;
59
60 /* local function prototypes */
61 static Scheme_Object *read_case_sensitive(int, Scheme_Object *[]);
62 static Scheme_Object *read_accept_pipe_quote(int, Scheme_Object *[]);
63 #ifdef LOAD_ON_DEMAND
64 static Scheme_Object *read_delay_load(int, Scheme_Object *[]);
65 #endif
66 static Scheme_Object *print_graph(int, Scheme_Object *[]);
67 static Scheme_Object *print_struct(int, Scheme_Object *[]);
68 static Scheme_Object *print_box(int, Scheme_Object *[]);
69 static Scheme_Object *print_vec_shorthand(int, Scheme_Object *[]);
70 static Scheme_Object *print_hash_table(int, Scheme_Object *[]);
71 static Scheme_Object *print_unreadable(int, Scheme_Object *[]);
72 static Scheme_Object *print_pair_curly(int, Scheme_Object *[]);
73 static Scheme_Object *print_mpair_curly(int, Scheme_Object *[]);
74 static Scheme_Object *print_syntax_width(int, Scheme_Object *[]);
75 static Scheme_Object *print_reader(int, Scheme_Object *[]);
76 static Scheme_Object *print_as_qq(int, Scheme_Object *[]);
77 static Scheme_Object *print_long_bool(int, Scheme_Object *[]);
78
79 #define NOT_EOF_OR_SPECIAL(x) ((x) >= 0)
80
81 #define isdigit_ascii(n) ((n >= '0') && (n <= '9'))
82
83 #define scheme_isxdigit(n) (isdigit_ascii(n) || ((n >= 'a') && (n <= 'f')) || ((n >= 'A') && (n <= 'F')))
84
85 #define mz_shape_cons 0
86 #define mz_shape_vec 1
87 #define mz_shape_hash_list 2
88 #define mz_shape_hash_elem 3
89 #define mz_shape_vec_plus_infix 4
90 #define mz_shape_fl_vec 5
91 #define mz_shape_fx_vec 6
92
93 #define MAX_GRAPH_ID_DIGITS 8
94
95 typedef struct ReadParams {
96 MZTAG_IF_REQUIRED
97 char skip_zo_vers_check;
98 char can_read_unsafe;
99 Scheme_Object *delay_load_info;
100 Scheme_Object *read_relative_path;
101 Scheme_Hash_Table *graph_ht;
102 } ReadParams;
103
104 #define THREAD_FOR_LOCALS scheme_current_thread
105
106 static Scheme_Object *read_list(Scheme_Object *port,
107 int opener, int closer,
108 int shape, int use_stack,
109 ReadParams *params);
110 static Scheme_Object *read_string(int is_byte,
111 Scheme_Object *port,
112 ReadParams *params,
113 int err_ok);
114 static Scheme_Object *read_quote(char *who, Scheme_Object *quote_symbol, int len,
115 Scheme_Object *port,
116 ReadParams *params);
117 static Scheme_Object *read_vector(Scheme_Object *port,
118 int opener, char closer,
119 ReadParams *params,
120 int allow_infix);
121 static Scheme_Object *read_number_or_symbol(int init_ch, Scheme_Object *port,
122 int is_float, int is_not_float,
123 int radix, int radix_set,
124 int is_symbol, int is_kw,
125 ReadParams *params);
126 static Scheme_Object *read_number(int init_ch,
127 Scheme_Object *port,
128 int, int, int, int,
129 ReadParams *params);
130 static Scheme_Object *read_symbol(int init_ch,
131 Scheme_Object *port,
132 ReadParams *params);
133 static Scheme_Object *read_keyword(int init_ch,
134 Scheme_Object *port,
135 ReadParams *params);
136 static Scheme_Object *read_delimited_constant(int ch, const mzchar *str,
137 Scheme_Object *v,
138 Scheme_Object *port,
139 ReadParams *params);
140 static Scheme_Object *read_character(Scheme_Object *port,
141 ReadParams *params);
142 static Scheme_Object *read_box(Scheme_Object *port,
143 ReadParams *params);
144 static Scheme_Object *read_hash(Scheme_Object *port,
145 int opener, char closer, int kind,
146 ReadParams *params);
147 static void unexpected_closer(int ch,
148 Scheme_Object *port);
149 static int next_is_delim(Scheme_Object *port);
150 static int read_graph_index(Scheme_Object *port, int *ch);
151 static int skip_whitespace_comments(Scheme_Object *port,
152 ReadParams *params);
153
154 static Scheme_Object *read_intern(int argc, Scheme_Object **argv);
155
156 #ifdef MZ_PRECISE_GC
157 static void register_traversers(void);
158 #endif
159
160 #define SCHEME_OK 0x1
161
162 #define NEXT_LINE_CHAR 0x85
163 #define LINE_SEPARATOR_CHAR 0x2028
164 #define PARAGRAPH_SEPARATOR_CHAR 0x2029
165 #define is_line_comment_end(ch) ((ch == '\n') || (ch == '\r') \
166 || (ch == NEXT_LINE_CHAR) \
167 || (ch == LINE_SEPARATOR_CHAR) \
168 || (ch == PARAGRAPH_SEPARATOR_CHAR))
169
170 /*========================================================================*/
171 /* initialization */
172 /*========================================================================*/
173
scheme_init_read(Scheme_Startup_Env * env)174 void scheme_init_read(Scheme_Startup_Env *env)
175 {
176 REGISTER_SO(quote_symbol);
177 REGISTER_SO(quasiquote_symbol);
178 REGISTER_SO(unquote_symbol);
179 REGISTER_SO(unquote_splicing_symbol);
180 REGISTER_SO(syntax_symbol);
181 REGISTER_SO(unsyntax_symbol);
182 REGISTER_SO(unsyntax_splicing_symbol);
183 REGISTER_SO(quasisyntax_symbol);
184
185 quote_symbol = scheme_intern_symbol("quote");
186 quasiquote_symbol = scheme_intern_symbol("quasiquote");
187 unquote_symbol = scheme_intern_symbol("unquote");
188 unquote_splicing_symbol = scheme_intern_symbol("unquote-splicing");
189 syntax_symbol = scheme_intern_symbol("syntax");
190 unsyntax_symbol = scheme_intern_symbol("unsyntax");
191 unsyntax_splicing_symbol = scheme_intern_symbol("unsyntax-splicing");
192 quasisyntax_symbol = scheme_intern_symbol("quasisyntax");
193
194 /* initialize cpt_branch */
195 {
196 int i;
197
198 for (i = 0; i < 256; i++) {
199 cpt_branch[i] = i;
200 }
201
202 #define FILL_IN(v) \
203 for (i = CPT_ ## v ## _START; i < CPT_ ## v ## _END; i++) { \
204 cpt_branch[i] = CPT_ ## v ## _START; \
205 }
206 FILL_IN(SMALL_NUMBER);
207 FILL_IN(SMALL_SYMBOL);
208 FILL_IN(SMALL_LIST);
209 FILL_IN(SMALL_PROPER_LIST);
210 FILL_IN(SMALL_LOCAL);
211 FILL_IN(SMALL_LOCAL_UNBOX);
212 FILL_IN(SMALL_SVECTOR);
213 FILL_IN(SMALL_APPLICATION);
214
215 /* These two are handled specially: */
216 cpt_branch[CPT_SMALL_APPLICATION2] = CPT_SMALL_APPLICATION2;
217 cpt_branch[CPT_SMALL_APPLICATION3] = CPT_SMALL_APPLICATION3;
218 }
219
220 {
221 int i;
222 for (i = 0; i < 128; i++) {
223 delim[i] = SCHEME_OK;
224 }
225 delim['('] -= SCHEME_OK;
226 delim[')'] -= SCHEME_OK;
227 delim['['] -= SCHEME_OK;
228 delim[']'] -= SCHEME_OK;
229 delim['{'] -= SCHEME_OK;
230 delim['}'] -= SCHEME_OK;
231 delim['"'] -= SCHEME_OK;
232 delim['\''] -= SCHEME_OK;
233 delim[','] -= SCHEME_OK;
234 delim[';'] -= SCHEME_OK;
235 delim['`'] -= SCHEME_OK;
236 }
237
238 #ifdef MZ_PRECISE_GC
239 register_traversers();
240 #endif
241
242 ADD_PARAMETER("read-case-sensitive", read_case_sensitive, MZCONFIG_CASE_SENS, env);
243 ADD_PARAMETER("read-accept-bar-quote", read_accept_pipe_quote, MZCONFIG_CAN_READ_PIPE_QUOTE, env);
244 #ifdef LOAD_ON_DEMAND
245 ADD_PARAMETER("read-on-demand-source", read_delay_load, MZCONFIG_DELAY_LOAD_INFO, env);
246 #endif
247 ADD_PARAMETER("print-graph", print_graph, MZCONFIG_PRINT_GRAPH, env);
248 ADD_PARAMETER("print-struct", print_struct, MZCONFIG_PRINT_STRUCT, env);
249 ADD_PARAMETER("print-box", print_box, MZCONFIG_PRINT_BOX, env);
250 ADD_PARAMETER("print-vector-length", print_vec_shorthand, MZCONFIG_PRINT_VEC_SHORTHAND, env);
251 ADD_PARAMETER("print-hash-table", print_hash_table, MZCONFIG_PRINT_HASH_TABLE, env);
252 ADD_PARAMETER("print-unreadable", print_unreadable, MZCONFIG_PRINT_UNREADABLE, env);
253 ADD_PARAMETER("print-pair-curly-braces", print_pair_curly, MZCONFIG_PRINT_PAIR_CURLY, env);
254 ADD_PARAMETER("print-mpair-curly-braces", print_mpair_curly, MZCONFIG_PRINT_MPAIR_CURLY, env);
255 ADD_PARAMETER("print-syntax-width", print_syntax_width, MZCONFIG_PRINT_SYNTAX_WIDTH, env);
256 ADD_PARAMETER("print-reader-abbreviations", print_reader, MZCONFIG_PRINT_READER, env);
257 ADD_PARAMETER("print-boolean-long-form", print_long_bool, MZCONFIG_PRINT_LONG_BOOLEAN, env);
258 ADD_PARAMETER("print-as-expression", print_as_qq, MZCONFIG_PRINT_AS_QQ, env);
259
260 ADD_NONCM_PRIM("datum-intern-literal", read_intern, 1, 1, env);
261
262 if (getenv("PLT_DELAY_FROM_ZO"))
263 use_perma_cache = 0;
264 if (getenv("PLT_VALIDATE_LOAD"))
265 validate_loaded_linklet = 0;
266 }
267
scheme_init_variable_references_constants()268 void scheme_init_variable_references_constants()
269 {
270 REGISTER_SO(variable_references);
271 variable_references = scheme_make_builtin_references_table(&unsafe_variable_references_start);
272 }
273
scheme_position_to_builtin(int l)274 Scheme_Object *scheme_position_to_builtin(int l)
275 {
276 if (l < EXPECTED_PRIM_COUNT)
277 return variable_references[l];
278 else
279 return NULL;
280 }
281
282 /*========================================================================*/
283 /* parameters */
284 /*========================================================================*/
285
286 #define DO_CHAR_PARAM(name, pos) \
287 return scheme_param_config(name, scheme_make_integer(pos), argc, argv, -1, NULL, NULL, 1)
288
289 static Scheme_Object *
read_case_sensitive(int argc,Scheme_Object * argv[])290 read_case_sensitive(int argc, Scheme_Object *argv[])
291 {
292 DO_CHAR_PARAM("read-case-sensitive", MZCONFIG_CASE_SENS);
293 }
294
295 static Scheme_Object *
read_accept_pipe_quote(int argc,Scheme_Object * argv[])296 read_accept_pipe_quote(int argc, Scheme_Object *argv[])
297 {
298 DO_CHAR_PARAM("read-accept-pipe-quote", MZCONFIG_CAN_READ_PIPE_QUOTE);
299 }
300
301 static Scheme_Object *
print_graph(int argc,Scheme_Object * argv[])302 print_graph(int argc, Scheme_Object *argv[])
303 {
304 DO_CHAR_PARAM("print-graph", MZCONFIG_PRINT_GRAPH);
305 }
306
307 static Scheme_Object *
print_struct(int argc,Scheme_Object * argv[])308 print_struct(int argc, Scheme_Object *argv[])
309 {
310 DO_CHAR_PARAM("print-struct", MZCONFIG_PRINT_STRUCT);
311 }
312
313 static Scheme_Object *
print_box(int argc,Scheme_Object * argv[])314 print_box(int argc, Scheme_Object *argv[])
315 {
316 DO_CHAR_PARAM("print-box", MZCONFIG_PRINT_BOX);
317 }
318
319 static Scheme_Object *
print_vec_shorthand(int argc,Scheme_Object * argv[])320 print_vec_shorthand(int argc, Scheme_Object *argv[])
321 {
322 DO_CHAR_PARAM("print-vector-length", MZCONFIG_PRINT_VEC_SHORTHAND);
323 }
324
325 static Scheme_Object *
print_hash_table(int argc,Scheme_Object * argv[])326 print_hash_table(int argc, Scheme_Object *argv[])
327 {
328 DO_CHAR_PARAM("print-hash-table", MZCONFIG_PRINT_HASH_TABLE);
329 }
330
331 static Scheme_Object *
print_unreadable(int argc,Scheme_Object * argv[])332 print_unreadable(int argc, Scheme_Object *argv[])
333 {
334 DO_CHAR_PARAM("print-unreadable", MZCONFIG_PRINT_UNREADABLE);
335 }
336
337 static Scheme_Object *
print_pair_curly(int argc,Scheme_Object * argv[])338 print_pair_curly(int argc, Scheme_Object *argv[])
339 {
340 DO_CHAR_PARAM("print-pair-curly", MZCONFIG_PRINT_PAIR_CURLY);
341 }
342
343 static Scheme_Object *
print_mpair_curly(int argc,Scheme_Object * argv[])344 print_mpair_curly(int argc, Scheme_Object *argv[])
345 {
346 DO_CHAR_PARAM("print-mpair-curly", MZCONFIG_PRINT_MPAIR_CURLY);
347 }
348
349 static Scheme_Object *
print_reader(int argc,Scheme_Object * argv[])350 print_reader(int argc, Scheme_Object *argv[])
351 {
352 DO_CHAR_PARAM("print-reader-abbreviations", MZCONFIG_PRINT_READER);
353 }
354
355 static Scheme_Object *
print_as_qq(int argc,Scheme_Object * argv[])356 print_as_qq(int argc, Scheme_Object *argv[])
357 {
358 DO_CHAR_PARAM("print-as-expression", MZCONFIG_PRINT_AS_QQ);
359 }
360
361 static Scheme_Object *
print_long_bool(int argc,Scheme_Object * argv[])362 print_long_bool(int argc, Scheme_Object *argv[])
363 {
364 DO_CHAR_PARAM("print-boolean-long-form", MZCONFIG_PRINT_LONG_BOOLEAN);
365 }
366
good_syntax_width(int c,Scheme_Object ** argv)367 static Scheme_Object *good_syntax_width(int c, Scheme_Object **argv)
368 {
369 int ok;
370
371 ok = (SCHEME_INTP(argv[0])
372 ? ((SCHEME_INT_VAL(argv[0]) > 2)
373 || !SCHEME_INT_VAL(argv[0]))
374 : (SCHEME_BIGNUMP(argv[0])
375 ? SCHEME_BIGPOS(argv[0])
376 : (SCHEME_DBLP(argv[0])
377 ? MZ_IS_POS_INFINITY(SCHEME_DBL_VAL(argv[0]))
378 : 0)));
379
380 return ok ? scheme_true : scheme_false;
381 }
382
383 static Scheme_Object *
print_syntax_width(int argc,Scheme_Object * argv[])384 print_syntax_width(int argc, Scheme_Object *argv[])
385 {
386 return scheme_param_config2("print-syntax-width",
387 scheme_make_integer(MZCONFIG_PRINT_SYNTAX_WIDTH),
388 argc, argv,
389 -1, good_syntax_width,
390 "(or/c +inf.0 0 (and/c exact-integer? (>=/c 3)))", 0);
391 }
392
393 #ifdef LOAD_ON_DEMAND
rdl_check(int argc,Scheme_Object ** argv)394 static Scheme_Object *rdl_check(int argc, Scheme_Object **argv)
395 {
396 Scheme_Object *s = argv[0];
397
398 return ((SCHEME_FALSEP(s)
399 || SAME_OBJ(scheme_true, s)
400 || (SCHEME_PATHP(s)
401 && scheme_is_complete_path(SCHEME_PATH_VAL(s),
402 SCHEME_PATH_LEN(s),
403 SCHEME_PLATFORM_PATH_KIND)))
404 ? scheme_true : scheme_false);
405 }
406
407 static Scheme_Object *
read_delay_load(int argc,Scheme_Object * argv[])408 read_delay_load(int argc, Scheme_Object *argv[])
409 {
410 return scheme_param_config2("read-on-demand-source",
411 scheme_make_integer(MZCONFIG_DELAY_LOAD_INFO),
412 argc, argv,
413 -1, rdl_check,
414 "(or/c #f #t (and/c path? complete-path?))",
415 0);
416
417 }
418 #endif
419
420 /*========================================================================*/
421 /* main read loop */
422 /*========================================================================*/
423
424 static Scheme_Object *read_inner(Scheme_Object *port, ReadParams *params, int pre_char);
425
read_inner_k(void)426 static Scheme_Object *read_inner_k(void)
427 {
428 Scheme_Thread *p = scheme_current_thread;
429 Scheme_Object *o = (Scheme_Object *)p->ku.k.p1;
430 ReadParams *params = (ReadParams *)SCHEME_CDR((Scheme_Object *)p->ku.k.p4);
431
432 p->ku.k.p1 = NULL;
433 p->ku.k.p4 = NULL;
434
435 return read_inner(o, params, p->ku.k.i2);
436 }
437
read_inner(Scheme_Object * port,ReadParams * params,int pre_char)438 static Scheme_Object *read_inner(Scheme_Object *port, ReadParams *params, int pre_char)
439 {
440 int ch, ch2;
441
442 #ifdef DO_STACK_CHECK
443 {
444 # include "mzstkchk.h"
445 {
446 Scheme_Thread *p = scheme_current_thread;
447 ReadParams *params2;
448
449 /* params may be on the stack, so move it to the heap: */
450 params2 = MALLOC_ONE_RT(ReadParams);
451 memcpy(params2, params, sizeof(ReadParams));
452 #ifdef MZ_PRECISE_GC
453 params2->type = scheme_rt_read_params;
454 #endif
455
456 p->ku.k.p1 = (void *)port;
457 p->ku.k.p4 = (void *)params2;
458 p->ku.k.i2 = pre_char;
459 return scheme_handle_stack_overflow(read_inner_k);
460 }
461 }
462 #endif
463
464 start_over:
465
466 SCHEME_USE_FUEL(1);
467
468 /* Skip whitespace */
469 while (1) {
470 if (pre_char >= 0) {
471 ch = pre_char;
472 pre_char = -1;
473 } else
474 ch = scheme_getc(port);
475 if (NOT_EOF_OR_SPECIAL(ch)) {
476 if (!scheme_isspace(ch))
477 break;
478 } else
479 break;
480 }
481
482 switch (ch)
483 {
484 case EOF:
485 return scheme_eof;
486 case ']':
487 unexpected_closer(ch, port);
488 return NULL;
489 case '}':
490 unexpected_closer(ch, port);
491 return NULL;
492 case ')':
493 unexpected_closer(ch, port);
494 return NULL;
495 case '(':
496 return read_list(port, ch, ')', mz_shape_cons, 0, params);
497 case '[':
498 return read_list(port, ch, ']', mz_shape_cons, 0, params);
499 case '{':
500 return read_list(port, ch, '}', mz_shape_cons, 0, params);
501 case '|':
502 return read_symbol(ch, port, params);
503 case '"':
504 return read_string(0, port, params, 1);
505 case '\'':
506 return read_quote("quoting '", quote_symbol, 1, port, params);
507 case '`':
508 return read_quote("quasiquoting `", quasiquote_symbol, 1, port, params);
509 case ',':
510 {
511 if (scheme_peekc(port) == '@') {
512 ch = scheme_getc(port); /* must be '@' */
513 return read_quote("unquoting ,@", unquote_splicing_symbol, 2, port, params);
514 } else
515 return read_quote("unquoting ,", unquote_symbol, 1, port, params);
516 }
517 case ';':
518 {
519 while (((ch = scheme_getc(port)) != '\n')
520 && !is_line_comment_end(ch)) {
521 if (ch == EOF)
522 return scheme_eof;
523 }
524 goto start_over;
525 }
526 case '#':
527 ch = scheme_getc(port);
528
529 switch (ch)
530 {
531 case EOF:
532 scheme_read_err(port, "read: bad syntax `#'");
533 return NULL;
534 case ';':
535 {
536 Scheme_Object *skipped;
537 skipped = read_inner(port, params, -1);
538 if (SCHEME_EOFP(skipped))
539 scheme_read_err(port, "read: expected a commented-out element for `#;' (found end-of-file)");
540 goto start_over;
541 }
542 case '%':
543 scheme_ungetc('%', port);
544 return read_symbol('#', port, params);
545 case ':':
546 return read_keyword(-1, port, params);
547 case '(':
548 return read_vector(port, ch, ')', params, 0);
549 case '[':
550 return read_vector(port, ch, ']', params, 0);
551 case '{':
552 return read_vector(port, ch, '}', params, 0);
553 case '\\':
554 return read_character(port, params);
555 case 'T':
556 case 't':
557 if (next_is_delim(port)) {
558 /* found delimited `#t' */
559 return scheme_true;
560 } else {
561 GC_CAN_IGNORE const mzchar str[] = { 't', 'r', 'u', 'e', 0 };
562 return read_delimited_constant(ch, str, scheme_true, port, params);
563 }
564 case 'F':
565 case 'f':
566 if (next_is_delim(port)) {
567 /* found delimited `#f' */
568 return scheme_false;
569 } else {
570 GC_CAN_IGNORE const mzchar str[] = { 'f', 'a', 'l', 's', 'e', 0 };
571 return read_delimited_constant(ch, str, scheme_false, port, params);
572 }
573 case 's':
574 case 'S':
575 {
576 int orig_ch = ch;
577 ch = scheme_getc(port);
578 if ((orig_ch == 's')
579 && ((ch == '(')
580 || (ch == '[')
581 || (ch == '{'))) {
582 Scheme_Object *v;
583 Scheme_Struct_Type *st;
584
585 if (ch == '(')
586 ch = ')';
587 else if (ch == '[')
588 ch = ']';
589 else if (ch == '{')
590 ch = '}';
591
592 v = read_vector(port, orig_ch, ch, params, 1);
593
594 if (SCHEME_VEC_SIZE(v))
595 st = scheme_lookup_prefab_type(SCHEME_VEC_ELS(v)[0], SCHEME_VEC_SIZE(v) - 1);
596 else
597 st = NULL;
598
599 if (!st || (st->num_slots != (SCHEME_VEC_SIZE(v) - 1))) {
600 scheme_read_err(port,
601 (SCHEME_VEC_SIZE(v)
602 ? (st
603 ? ("read: mismatch between structure description"
604 " and number of provided field values in `#s' form")
605 : "read: invalid structure description in `#s' form")
606 : "read: missing structure description in `#s' form"));
607 return NULL;
608 }
609
610 v = scheme_make_prefab_struct_instance(st, v);
611
612 return v;
613 } else {
614 scheme_read_err(port,
615 "read: expected `x'%s after `#%c'",
616 (orig_ch == 's' ? "or `('" : ""),
617 orig_ch);
618 return NULL;
619 }
620 }
621 case 'X':
622 case 'x':
623 return read_number(-1, port, 0, 0, 16, 1, params);
624 case 'B':
625 case 'b':
626 return read_number(-1, port, 0, 0, 2, 1, params);
627 case 'O':
628 case 'o':
629 return read_number(-1, port, 0, 0, 8, 1, params);
630 case 'D':
631 case 'd':
632 return read_number(-1, port, 0, 0, 10, 1, params);
633 case 'E':
634 case 'e':
635 return read_number(-1, port, 0, 1, 10, 0, params);
636 case 'I':
637 case 'i':
638 return read_number(-1, port, 1, 0, 10, 0, params);
639 case '\'':
640 return read_quote("quoting #'", syntax_symbol, 2, port, params);
641 case '`':
642 return read_quote("quasiquoting #`", quasisyntax_symbol, 2, port, params);
643 case ',':
644 if (scheme_peekc(port) == '@') {
645 (void)scheme_getc(port); /* must be '@' */
646 return read_quote("unquoting #`@", unsyntax_splicing_symbol, 3, port, params);
647 } else
648 return read_quote("unquoting #`", unsyntax_symbol, 2, port, params);
649 case '^':
650 {
651 ch = scheme_getc(port);
652 if (ch == '#') {
653 ch = scheme_getc(port);
654 if (ch == '"') {
655 Scheme_Object *str;
656
657 str = read_string(1, port, params, 1);
658
659 str->type = SCHEME_PLATFORM_PATH_KIND;
660
661 if (scheme_is_relative_path(SCHEME_PATH_VAL(str), SCHEME_PATH_LEN(str), SCHEME_PLATFORM_PATH_KIND)) {
662 if (SCHEME_PATHP(params->read_relative_path)) {
663 Scheme_Object *a[2];
664 a[0] = params->read_relative_path;
665 a[1] = str;
666 str = scheme_build_path(2, a);
667 a[0] = str;
668 a[1] = scheme_false;
669 str = scheme_simplify_path(2, a);
670 }
671 }
672
673 return str;
674 } else {
675 scheme_read_err(port, "read: bad syntax `#^#%c'", ch);
676 return NULL;
677 }
678 } else {
679 scheme_read_err(port, "read: bad syntax `#^%c'", ch);
680 return NULL;
681 }
682 }
683 break;
684 case '|':
685 {
686 intptr_t depth = 0;
687 ch2 = 0;
688 do {
689 ch = scheme_getc(port);
690
691 if (ch == EOF)
692 scheme_read_err(port, "read: end of file in #| comment");
693
694 if ((ch2 == '|') && (ch == '#')) {
695 if (!(depth--))
696 goto start_over;
697 ch = 0; /* So we don't count '#' toward an opening "#|" */
698 } else if ((ch2 == '#') && (ch == '|')) {
699 depth++;
700 ch = 0; /* So we don't count '|' toward a closing "|#" */
701 }
702 ch2 = ch;
703 } while (1);
704 }
705 break;
706 case '&':
707 return read_box(port, params);
708 case 'r':
709 case 'p':
710 {
711 int orig_ch = ch;
712 int cnt = 0, is_byte = 0;
713 char *expect;
714
715 ch = scheme_getc(port);
716 if (ch == 'x') {
717 expect = "x#";
718 ch = scheme_getc(port);
719 cnt++;
720 if (ch == '#') {
721 is_byte = 1;
722 cnt++;
723 ch = scheme_getc(port);
724 }
725 if (ch == '"') {
726 Scheme_Object *str;
727 int is_err;
728
729 str = read_string(is_byte, port, params, 1);
730
731 str = scheme_make_regexp(str, is_byte, (orig_ch == 'p'), &is_err);
732
733 if (is_err) {
734 scheme_read_err(port, "read: bad %sregexp string `%s`",
735 (orig_ch == 'r') ? "" : "p",
736 (char *)str);
737 return NULL;
738 }
739
740 return str;
741 }
742 } else
743 expect = "";
744
745 {
746 mzchar a[6];
747 int i;
748
749 for (i = 0; i < cnt; i++) {
750 a[i] = expect[i];
751 }
752 if (NOT_EOF_OR_SPECIAL(ch)) {
753 a[cnt++] = ch;
754 }
755
756 scheme_read_err(port, "read: bad syntax `#%c%u`",
757 orig_ch, a, (intptr_t)cnt);
758 return NULL;
759 }
760 }
761 break;
762 case 'h':
763 {
764 ch = scheme_getc(port);
765 if (ch != 'a') {
766 scheme_read_err(port, "read: expected `a` after `#h`");
767 return NULL;
768 } else {
769 GC_CAN_IGNORE const mzchar str[] = { 's', 'h', 'e', 'q', 'v', 0 };
770 int scanpos = 0, failed = 0;
771
772 do {
773 ch = scheme_getc(port);
774 if ((mzchar)ch == str[scanpos]) {
775 scanpos++;
776 } else {
777 if ((scanpos == 2) || (scanpos == 4)) {
778 if (!(ch == '(')
779 && !(ch == '[')
780 && !(ch == '{'))
781 failed = 1;
782 } else
783 failed = 1;
784 break;
785 }
786 } while (str[scanpos]);
787
788 if (!failed) {
789 /* Found recognized tag. Look for open paren... */
790 int kind;
791
792 if (scanpos > 4)
793 ch = scheme_getc(port);
794
795 if (scanpos == 4)
796 kind = 0;
797 else if (scanpos == 2)
798 kind = 1;
799 else
800 kind = 2;
801
802 if (ch == '(')
803 return read_hash(port, ch, ')', kind, params);
804 if (ch == '[')
805 return read_hash(port, ch, ']', kind, params);
806 if (ch == '{')
807 return read_hash(port, ch, '}', kind, params);
808 }
809
810 /* Report an error. So far, we read 'ha', then scanpos chars of str, then ch. */
811 {
812 mzchar str_part[7], one_more[2];
813
814 memcpy(str_part, str, scanpos * sizeof(mzchar));
815 str_part[scanpos] = 0;
816 if (NOT_EOF_OR_SPECIAL(ch)) {
817 one_more[0] = ch;
818 one_more[1] = 0;
819 } else
820 one_more[0] = 0;
821
822 scheme_read_err(port, "read: bad syntax `#ha%5%u'",
823 str_part,
824 one_more, (intptr_t)(NOT_EOF_OR_SPECIAL(ch) ? 1 : 0));
825 return NULL;
826 }
827 }
828 }
829 break;
830 case '"':
831 return read_string(1, port, params, 1);
832 default:
833 if (ch == '(')
834 return read_vector(port, ch, ')', params, 0);
835 else if (ch == '[')
836 return read_vector(port, ch, ']', params, 0);
837 else if (ch == '{')
838 return read_vector(port, ch, '}', params, 0);
839 else if (isdigit_ascii(ch)) {
840 /* graph definition or reference */
841 int nch = ch, index;
842 Scheme_Object *val;
843
844 index = read_graph_index(port, &nch);
845 switch (nch) {
846 case '#':
847 if (params->graph_ht)
848 val = scheme_hash_get(params->graph_ht, scheme_make_integer(index));
849 else
850 val = NULL;
851 if (!val)
852 scheme_read_err(port,
853 "read: no value for `#%d#`",
854 index);
855 return val;
856 case '=':
857 if (!params->graph_ht) {
858 Scheme_Hash_Table *ht;
859 ht = scheme_make_hash_table(SCHEME_hash_ptr);
860 params->graph_ht = ht;
861 }
862 if (scheme_hash_get(params->graph_ht, scheme_make_integer(index)))
863 scheme_read_err(port,
864 "read: duplicate `#%d=` definition",
865 index);
866 val = read_inner(port, params, -1);
867 scheme_hash_set(params->graph_ht, scheme_make_integer(index), val);
868 return val;
869 default:
870 scheme_read_err(port,
871 "read: expected `=` or `#` after `#%d`, found `%c`",
872 index, nch);
873 return NULL;
874 }
875
876 } else {
877 scheme_read_err(port, "read: bad syntax `#%c`", ch);
878 return NULL;
879 }
880 }
881 default:
882 return read_number_or_symbol(ch, port, 0, 0, 10, 0, 0, 0, params);
883 }
884 }
885
886 #ifdef DO_STACK_CHECK
887 static Scheme_Object *resolve_references(Scheme_Object *obj,
888 Scheme_Object *top,
889 Scheme_Hash_Table *dht,
890 Scheme_Hash_Table *tht,
891 Scheme_Hash_Table *self_contained_ht,
892 int clone,
893 int tail_depth);
894
resolve_k(void)895 static Scheme_Object *resolve_k(void)
896 {
897 Scheme_Thread *p = scheme_current_thread;
898 Scheme_Object *o = (Scheme_Object *)p->ku.k.p1;
899 Scheme_Object *top = (Scheme_Object *)p->ku.k.p5;
900 Scheme_Hash_Table *dht = (Scheme_Hash_Table *)p->ku.k.p3;
901 Scheme_Hash_Table *tht = (Scheme_Hash_Table *)SCHEME_CAR((Scheme_Object *)p->ku.k.p4);
902 Scheme_Hash_Table *self_contained_ht = (Scheme_Hash_Table *)SCHEME_CDR((Scheme_Object *)p->ku.k.p4);
903
904 p->ku.k.p1 = NULL;
905 p->ku.k.p3 = NULL;
906 p->ku.k.p4 = NULL;
907 p->ku.k.p5 = NULL;
908
909 return resolve_references(o, top, dht, tht, self_contained_ht, p->ku.k.i1, p->ku.k.i2);
910 }
911 #endif
912
resolve_references(Scheme_Object * obj,Scheme_Object * top,Scheme_Hash_Table * dht,Scheme_Hash_Table * tht,Scheme_Hash_Table * self_contained_ht,int clone,int tail_depth)913 static Scheme_Object *resolve_references(Scheme_Object *obj,
914 Scheme_Object *top,
915 Scheme_Hash_Table *dht,
916 Scheme_Hash_Table *tht,
917 Scheme_Hash_Table *self_contained_ht,
918 int clone,
919 int tail_depth)
920 {
921 Scheme_Object *result;
922
923 #ifdef DO_STACK_CHECK
924 {
925 # include "mzstkchk.h"
926 {
927 Scheme_Thread *p = scheme_current_thread;
928 p->ku.k.p1 = (void *)obj;
929 p->ku.k.p5 = (void *)top;
930 p->ku.k.p3 = (void *)dht;
931 result = scheme_make_pair((Scheme_Object *)tht,
932 (Scheme_Object *)self_contained_ht);
933 p->ku.k.p4 = (void *)result;
934 p->ku.k.i1 = clone;
935 p->ku.k.i2 = tail_depth;
936 return scheme_handle_stack_overflow(resolve_k);
937 }
938 }
939 #endif
940
941 SCHEME_USE_FUEL(1);
942
943 if (SAME_TYPE(SCHEME_TYPE(obj), scheme_placeholder_type)) {
944 Scheme_Object *start = obj;
945 while (SAME_TYPE(SCHEME_TYPE(obj), scheme_placeholder_type)) {
946 obj = (Scheme_Object *)SCHEME_PTR_VAL(obj);
947 if (SAME_OBJ(start, obj)) {
948 scheme_contract_error("make-reader-graph",
949 "illegal placeholder cycle in value",
950 "value", 1, top,
951 NULL);
952 return NULL;
953 }
954 }
955 }
956
957 if (self_contained_ht
958 && scheme_hash_get(self_contained_ht, obj))
959 return obj;
960
961 result = scheme_hash_get(dht, obj);
962 if (result) {
963 if (SCHEME_PAIRP(result)) {
964 obj = scheme_hash_get(tht, result);
965 if (obj && (SCHEME_INT_VAL(obj) == tail_depth))
966 SCHEME_PAIR_FLAGS(result) |= PAIR_IS_NON_LIST;
967 }
968 return result;
969 }
970
971 result = obj;
972
973 if (SCHEME_PAIRP(obj)) {
974 Scheme_Object *rr;
975
976 if (clone)
977 result = scheme_make_pair(scheme_false, scheme_false);
978 scheme_hash_set(dht, obj, result);
979
980 rr = resolve_references(SCHEME_CAR(obj), top, dht, tht, self_contained_ht,
981 clone, tail_depth + 1);
982 SCHEME_CAR(result) = rr;
983
984 scheme_hash_set(tht, result, scheme_make_integer(tail_depth));
985
986 rr = resolve_references(SCHEME_CDR(obj), top, dht, tht, self_contained_ht,
987 clone, tail_depth);
988 SCHEME_CDR(result) = rr;
989
990 scheme_hash_set(tht, result, NULL);
991
992 if (clone
993 && SAME_OBJ(SCHEME_CAR(obj), SCHEME_CAR(result))
994 && SAME_OBJ(SCHEME_CDR(obj), SCHEME_CDR(result))) {
995 /* No changes, so we don't actually have to clone. */
996 result = obj;
997 scheme_hash_set(dht, obj, result);
998 }
999 } else if (SCHEME_BOXP(obj)) {
1000 Scheme_Object *rr;
1001
1002 if (clone) {
1003 result = scheme_box(scheme_false);
1004 if (SCHEME_IMMUTABLEP(obj))
1005 SCHEME_SET_IMMUTABLE(result);
1006 }
1007 scheme_hash_set(dht, obj, result);
1008
1009 rr = resolve_references(SCHEME_BOX_VAL(obj), top, dht, tht, self_contained_ht,
1010 clone, tail_depth + 1);
1011 SCHEME_BOX_VAL(result) = rr;
1012
1013 if (clone
1014 && SAME_OBJ(SCHEME_PTR_VAL(obj), SCHEME_PTR_VAL(result))) {
1015 result = obj;
1016 scheme_hash_set(dht, obj, result);
1017 }
1018 } else if (SCHEME_VECTORP(obj)
1019 || (clone && SCHEME_CHAPERONE_VECTORP(obj))) {
1020 int i, len, diff = 0;
1021 Scheme_Object *prev_rr, *prev_v;
1022
1023 if (SCHEME_NP_CHAPERONEP(obj))
1024 obj = scheme_chaperone_vector_copy(obj);
1025
1026 len = SCHEME_VEC_SIZE(obj);
1027
1028 if (clone) {
1029 result = scheme_make_vector(len, scheme_false);
1030 if (SCHEME_IMMUTABLEP(obj))
1031 SCHEME_SET_IMMUTABLE(result);
1032 }
1033 scheme_hash_set(dht, obj, result);
1034
1035 prev_v = prev_rr = NULL;
1036 for (i = 0; i < len; i++) {
1037 Scheme_Object *rr;
1038 if (SCHEME_VEC_ELS(obj)[i] == prev_v) {
1039 rr = prev_rr;
1040 } else {
1041 prev_v = SCHEME_VEC_ELS(obj)[i];
1042 rr = resolve_references(prev_v, top, dht, tht, self_contained_ht,
1043 clone, tail_depth + 1);
1044 if (!SAME_OBJ(prev_v, rr))
1045 diff = 1;
1046 prev_rr = rr;
1047 }
1048 SCHEME_VEC_ELS(result)[i] = rr;
1049 }
1050
1051 if (clone && !diff) {
1052 result = obj;
1053 scheme_hash_set(dht, obj, result);
1054 }
1055 } else if (SAME_TYPE(SCHEME_TYPE(obj), scheme_table_placeholder_type)
1056 || SCHEME_HASHTRP(obj)
1057 || (clone && SCHEME_NP_CHAPERONEP(obj)
1058 && (SCHEME_HASHTP(SCHEME_CHAPERONE_VAL(obj))
1059 || SCHEME_HASHTRP(SCHEME_CHAPERONE_VAL(obj))))) {
1060 Scheme_Hash_Tree *t, *base;
1061 Scheme_Object *a, *key, *val, *lst;
1062 int kind;
1063
1064 if (SCHEME_NP_CHAPERONEP(obj))
1065 obj = scheme_chaperone_hash_table_copy(obj);
1066
1067 if (SCHEME_HASHTRP(obj)) {
1068 mzlonglong i;
1069 if (scheme_is_hash_tree_equal(obj))
1070 kind = 1;
1071 else if (scheme_is_hash_tree_eqv(obj))
1072 kind = 2;
1073 else
1074 kind = 0;
1075 t = (Scheme_Hash_Tree *)obj;
1076 lst = scheme_null;
1077 for (i = scheme_hash_tree_next(t, -1); i != -1; i = scheme_hash_tree_next(t, i)) {
1078 scheme_hash_tree_index(t, i, &key, &val);
1079 lst = scheme_make_pair(scheme_make_pair(key, val), lst);
1080 }
1081 } else {
1082 kind = SCHEME_PINT_VAL(obj);
1083 lst = SCHEME_IPTR_VAL(obj);
1084 }
1085
1086 /* Create `t' to be overwritten, and create `base' to extend. */
1087 base = scheme_make_hash_tree(kind);
1088 if (SCHEME_NULLP(lst))
1089 t = base;
1090 else
1091 t = scheme_make_hash_tree_placeholder(kind);
1092
1093 result = (Scheme_Object *)t;
1094 scheme_hash_set(dht, obj, result);
1095
1096 lst = resolve_references(lst, top, dht, tht, self_contained_ht,
1097 clone, tail_depth + 1);
1098
1099 for (; SCHEME_PAIRP(lst); lst = SCHEME_CDR(lst)) {
1100 a = SCHEME_CAR(lst);
1101 key = SCHEME_CAR(a);
1102 val = SCHEME_CDR(a);
1103
1104 base = scheme_hash_tree_set(base, key, val);
1105 }
1106
1107 if (base->count)
1108 scheme_hash_tree_tie_placeholder(t, base);
1109 } else if (SCHEME_HASHTP(obj)) {
1110 int i;
1111 Scheme_Object *key, *val, *l = scheme_null, *orig_l;
1112 Scheme_Hash_Table *t = (Scheme_Hash_Table *)obj, *t2;
1113
1114 t2 = scheme_clone_hash_table(t);
1115 scheme_reset_hash_table(t2, NULL);
1116 result = (Scheme_Object *)t2;
1117
1118 scheme_hash_set(dht, obj, (Scheme_Object *)t2);
1119
1120 for (i = t->size; i--; ) {
1121 if (t->vals[i]) {
1122 key = t->keys[i];
1123 val = t->vals[i];
1124 l = scheme_make_pair(scheme_make_pair(key, val), l);
1125 }
1126 }
1127
1128 orig_l = l;
1129 l = resolve_references(l, top, dht, tht, self_contained_ht,
1130 clone, tail_depth + 1);
1131
1132 if (SAME_OBJ(l, orig_l)) {
1133 result = obj;
1134 scheme_hash_set(dht, obj, result);
1135 } else {
1136 for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
1137 val = SCHEME_CAR(l);
1138 key = SCHEME_CAR(val);
1139 val = SCHEME_CDR(val);
1140
1141 scheme_hash_set(t2, key, val);
1142 }
1143 }
1144 } else if (SCHEME_STRUCTP(obj)
1145 || (clone && SCHEME_CHAPERONE_STRUCTP(obj))) {
1146 Scheme_Structure *s;
1147 if (clone && SCHEME_CHAPERONEP(obj))
1148 s = (Scheme_Structure *)SCHEME_CHAPERONE_VAL(obj);
1149 else
1150 s = (Scheme_Structure *)obj;
1151 if (s->stype->prefab_key) {
1152 /* prefab */
1153 int c, i, diff;
1154 Scheme_Object *prev_v, *v;
1155
1156 if (clone) {
1157 result = scheme_clone_prefab_struct_instance((Scheme_Structure *)obj);
1158 }
1159 scheme_hash_set(dht, obj, result);
1160
1161 c = s->stype->num_slots;
1162 diff = 0;
1163 for (i = 0; i < c; i++) {
1164 prev_v = ((Scheme_Structure *)result)->slots[i];
1165 v = resolve_references(prev_v, top, dht, tht, self_contained_ht,
1166 clone, tail_depth + 1);
1167 if (!SAME_OBJ(prev_v, v))
1168 diff = 1;
1169 ((Scheme_Structure *)result)->slots[i] = v;
1170 }
1171
1172 if (clone && !diff) {
1173 result = obj;
1174 scheme_hash_set(dht, obj, result);
1175 }
1176 }
1177 }
1178
1179 return result;
1180 }
1181
1182 static Scheme_Object *
_internal_read(Scheme_Object * port,int crc,int cant_fail,int extra_char,Scheme_Object * delay_load_info)1183 _internal_read(Scheme_Object *port, int crc, int cant_fail,
1184 int extra_char,
1185 Scheme_Object *delay_load_info)
1186 {
1187 Scheme_Object *v, *v2;
1188 ReadParams params;
1189
1190 if (crc >= 0) {
1191 params.can_read_unsafe = 1;
1192 } else {
1193 v = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR);
1194 v2 = scheme_get_initial_inspector();
1195 params.can_read_unsafe = SAME_OBJ(v, v2);
1196 }
1197 params.read_relative_path = NULL;
1198 if (!delay_load_info)
1199 delay_load_info = scheme_get_param(scheme_current_config(), MZCONFIG_DELAY_LOAD_INFO);
1200 if (SCHEME_TRUEP(delay_load_info))
1201 params.delay_load_info = delay_load_info;
1202 else
1203 params.delay_load_info = NULL;
1204 params.skip_zo_vers_check = cant_fail;
1205 params.graph_ht = NULL;
1206
1207 v = read_inner(port, ¶ms, extra_char);
1208
1209 if (params.graph_ht)
1210 v = resolve_references(v, NULL,
1211 scheme_make_hash_table(SCHEME_hash_ptr),
1212 scheme_make_hash_table(SCHEME_hash_ptr),
1213 NULL, 0, 0);
1214
1215 return v;
1216 }
1217
scheme_internal_read_k(void)1218 static void *scheme_internal_read_k(void)
1219 {
1220 Scheme_Thread *p = scheme_current_thread;
1221 Scheme_Object *port = (Scheme_Object *)p->ku.k.p1;
1222 Scheme_Object *delay_load_info = (Scheme_Object *)p->ku.k.p5;
1223
1224 p->ku.k.p1 = NULL;
1225 p->ku.k.p4 = NULL;
1226 p->ku.k.p5 = NULL;
1227
1228 return (void *)_internal_read(port, p->ku.k.i1, 0, p->ku.k.i4, delay_load_info);
1229 }
1230
1231 Scheme_Object *
scheme_internal_read(Scheme_Object * port,int crc,int cantfail,int pre_char,Scheme_Object * delay_load_info)1232 scheme_internal_read(Scheme_Object *port, int crc, int cantfail,
1233 int pre_char,
1234 Scheme_Object *delay_load_info)
1235 {
1236 Scheme_Thread *p = scheme_current_thread;
1237
1238 if (cantfail) {
1239 return _internal_read(port, crc, cantfail, -1, delay_load_info);
1240 } else {
1241 p->ku.k.p1 = (void *)port;
1242 p->ku.k.i1 = crc;
1243 p->ku.k.i4 = pre_char;
1244 p->ku.k.p5 = (void *)delay_load_info;
1245
1246 return (Scheme_Object *)scheme_top_level_do(scheme_internal_read_k, 0);
1247 }
1248 }
1249
scheme_read(Scheme_Object * port)1250 Scheme_Object *scheme_read(Scheme_Object *port)
1251 {
1252 Scheme_Object *read_proc, *a[1];
1253 read_proc = scheme_get_startup_export("read");
1254 a[0] = port;
1255 return scheme_apply(read_proc, 1, a);
1256 }
1257
scheme_read_syntax(Scheme_Object * port,Scheme_Object * stxsrc)1258 Scheme_Object *scheme_read_syntax(Scheme_Object *port, Scheme_Object *stxsrc)
1259 {
1260 Scheme_Object *read_syntax_proc, *a[2];
1261 read_syntax_proc = scheme_get_startup_export("read-syntax");
1262 a[0] = stxsrc;
1263 a[1] = port;
1264 return scheme_apply(read_syntax_proc, 2, a);
1265 }
1266
scheme_resolve_placeholders(Scheme_Object * obj)1267 Scheme_Object *scheme_resolve_placeholders(Scheme_Object *obj)
1268 {
1269 return resolve_references(obj, obj,
1270 scheme_make_hash_table(SCHEME_hash_ptr),
1271 scheme_make_hash_table(SCHEME_hash_ptr),
1272 NULL,
1273 1, 0);
1274 }
1275
1276 /*========================================================================*/
1277 /* list reader */
1278 /*========================================================================*/
1279
next_is_delim(Scheme_Object * port)1280 static int next_is_delim(Scheme_Object *port)
1281 {
1282 int next;
1283 next = scheme_peekc(port);
1284 return ((next == EOF)
1285 || (next == SCHEME_SPECIAL)
1286 || (scheme_isspace(next)
1287 || (next == '(')
1288 || (next == ')')
1289 || (next == '"')
1290 || (next == ';')
1291 || (next == '\'')
1292 || (next == '`')
1293 || (next == ',')
1294 || ((next == '['))
1295 || ((next == '{'))
1296 || ((next == ']'))
1297 || ((next == '}'))));
1298 }
1299
1300 /* "(" (or other opener) has already been read */
1301 static Scheme_Object *
read_list(Scheme_Object * port,int opener,int closer,int shape,int use_stack,ReadParams * params)1302 read_list(Scheme_Object *port,
1303 int opener, int closer, int shape, int use_stack,
1304 ReadParams *params)
1305 {
1306 Scheme_Object *list = NULL, *last = NULL, *car, *cdr, *pair, *infixed = NULL;
1307 int ch = 0, got_ch_already = 0;
1308
1309 while (1) {
1310 if (got_ch_already)
1311 got_ch_already = 0;
1312 else
1313 ch = skip_whitespace_comments(port, params);
1314
1315 if ((ch == EOF) && (closer != EOF)) {
1316 scheme_read_err(port, "read: expected a `%c` to close `%c`", closer, opener);
1317 return NULL;
1318 }
1319
1320 if (ch == closer) {
1321 if (shape == mz_shape_hash_elem) {
1322 scheme_read_err(port, "read: expected hash pair (with key and value separated by `.`) before `%c`", ch);
1323 return NULL;
1324 }
1325 if (!list) list = scheme_null;
1326 return list;
1327 }
1328
1329 if (shape == mz_shape_hash_list) {
1330 /* Make sure we found a parenthesized something. */
1331 if (!(ch == '(')
1332 && !(ch == '[')
1333 && !(ch == '{')) {
1334 scheme_read_err(port, "read: expected `(`, `[`, or `{` to start a hash pair");
1335 return NULL;
1336 } else {
1337 /* Found paren. Use read_list directly so we can specify mz_shape_hash_elem. */
1338 car = read_list(port,
1339 ch, ((ch == '(') ? ')' : ((ch == '[') ? ']' : '}')),
1340 mz_shape_hash_elem, use_stack, params);
1341 /* car is guaranteed to have an appropriate shape */
1342 }
1343 } else {
1344 car = read_inner(port, params, ch);
1345 /* can't be eof, due to check above */
1346 }
1347
1348 pair = scheme_make_pair(car, scheme_null);
1349
1350 ch = skip_whitespace_comments(port, params);
1351 if (ch == closer) {
1352 if (shape == mz_shape_hash_elem) {
1353 scheme_read_err(port, "read: expected `.` and value for hash before `%c`", ch);
1354 return NULL;
1355 }
1356
1357 cdr = pair;
1358 if (!list)
1359 list = cdr;
1360 else
1361 SCHEME_CDR(last) = cdr;
1362
1363 if (infixed) {
1364 list = scheme_make_pair(infixed, list);
1365 }
1366 return list;
1367 } else if ((ch == '.')
1368 && next_is_delim(port)) {
1369 if (((shape != mz_shape_cons)
1370 && (shape != mz_shape_hash_elem)
1371 && (shape != mz_shape_vec_plus_infix))
1372 || infixed) {
1373 scheme_read_err(port, "read: illegal use of `.`");
1374 return NULL;
1375 }
1376
1377 /* can't be eof, due to check above: */
1378 cdr = read_inner(port, params, -1);
1379 ch = skip_whitespace_comments(port, params);
1380 if ((ch != closer) || (shape == mz_shape_vec_plus_infix)) {
1381 if ((ch == '.')
1382 && next_is_delim(port)) {
1383 /* Parse as infix: */
1384
1385 if (shape == mz_shape_hash_elem) {
1386 scheme_read_err(port, "read: expected `%c` after hash value", closer);
1387 return NULL;
1388 }
1389
1390 infixed = cdr;
1391
1392 if (!list)
1393 list = pair;
1394 else
1395 SCHEME_CDR(last) = pair;
1396 last = pair;
1397
1398 /* Make sure there's not a closing paren immediately after the dot: */
1399 ch = skip_whitespace_comments(port, params);
1400 if ((ch == closer) || (ch == EOF)) {
1401 scheme_read_err(port, "read: illegal use of `%c`", ch);
1402 return NULL;
1403 }
1404 got_ch_already = 1;
1405 } else {
1406 scheme_read_err(port, "read: illegal use of `.`");
1407 return NULL;
1408 }
1409 } else {
1410 SCHEME_CDR(pair) = cdr;
1411 cdr = pair;
1412 if (!list)
1413 list = cdr;
1414 else
1415 SCHEME_CDR(last) = cdr;
1416
1417 /* Assert: infixed is NULL (otherwise we raised an exception above) */
1418 return list;
1419 }
1420 } else {
1421 got_ch_already = 1;
1422
1423 if (shape == mz_shape_hash_elem) {
1424 scheme_read_err(port, "read: expected `.` and value for hash");
1425 return NULL;
1426 }
1427
1428 cdr = pair;
1429 if (!list)
1430 list = cdr;
1431 else
1432 SCHEME_CDR(last) = cdr;
1433 last = cdr;
1434 }
1435 }
1436 }
1437
1438 /*========================================================================*/
1439 /* string reader */
1440 /*========================================================================*/
1441
1442 /* '"' has already been read */
1443 static Scheme_Object *
read_string(int is_byte,Scheme_Object * port,ReadParams * params,int err_ok)1444 read_string(int is_byte, Scheme_Object *port, ReadParams *params, int err_ok)
1445 {
1446 mzchar *buf, *oldbuf, onstack[32];
1447 int i, j, n, n1, ch, closer = '"';
1448 intptr_t size = 31, oldsize;
1449 Scheme_Object *result;
1450
1451 i = 0;
1452 buf = onstack;
1453 while (1) {
1454 ch = scheme_getc(port);
1455 if (ch == closer)
1456 break;
1457
1458 if (ch == EOF) {
1459 if (err_ok)
1460 scheme_read_err(port, "read: expected a closing %s%s",
1461 "'\"'",
1462 (ch == EOF) ? "" : " after one character");
1463 return NULL;
1464 }
1465 /* Note: errors will tend to leave junk on the port, with an open \". */
1466 /* Escape-sequence handling by Eli Barzilay. */
1467 if (ch == '\\') {
1468 ch = scheme_getc(port);
1469 if (ch == EOF) {
1470 if (err_ok)
1471 scheme_read_err(port, "read: expected a closing %s", "'\"'");
1472 return NULL;
1473 }
1474 switch ( ch ) {
1475 case '\\': case '\"': case '\'': break;
1476 case 'a': ch = '\a'; break;
1477 case 'b': ch = '\b'; break;
1478 case 'e': ch = 27; break; /* escape */
1479 case 'f': ch = '\f'; break;
1480 case 'n': ch = '\n'; break;
1481 case 'r': ch = '\r'; break;
1482 case 't': ch = '\t'; break;
1483 case 'v': ch = '\v'; break;
1484 case '\r':
1485 if (scheme_peekc(port) == '\n')
1486 scheme_getc(port);
1487 continue; /* <---------- !!!! */
1488 case '\n':
1489 continue; /* <---------- !!!! */
1490 case 'x':
1491 ch = scheme_getc(port);
1492 if (NOT_EOF_OR_SPECIAL(ch) && scheme_isxdigit(ch)) {
1493 n = ch<='9' ? ch-'0' : (scheme_toupper(ch)-'A'+10);
1494 ch = scheme_peekc(port);
1495 if (NOT_EOF_OR_SPECIAL(ch) && scheme_isxdigit(ch)) {
1496 n = n*16 + (ch<='9' ? ch-'0' : (scheme_toupper(ch)-'A'+10));
1497 scheme_getc(port); /* must be ch */
1498 }
1499 ch = n;
1500 } else {
1501 if (err_ok)
1502 scheme_read_err(port, "read: no hex digit following \\x in string");
1503 return NULL;
1504 }
1505 break;
1506 case 'u':
1507 case 'U':
1508 if (!is_byte) {
1509 int maxc = ((ch == 'u') ? 4 : 8);
1510 char initial[9];
1511 ch = scheme_getc(port);
1512 if (NOT_EOF_OR_SPECIAL(ch) && scheme_isxdigit(ch)) {
1513 int count = 1;
1514 initial[0] = ch;
1515 n = ch<='9' ? ch-'0' : (scheme_toupper(ch)-'A'+10);
1516 while (count < maxc) {
1517 ch = scheme_peekc(port);
1518 if (NOT_EOF_OR_SPECIAL(ch) && scheme_isxdigit(ch)) {
1519 initial[count] = ch;
1520 n = ((unsigned)n<<4) + (ch<='9' ? ch-'0' : (scheme_toupper(ch)-'A'+10));
1521 scheme_getc(port); /* must be ch */
1522 count++;
1523 } else
1524 break;
1525 }
1526 initial[count] = 0;
1527 if ((maxc == 4) && ((n >= 0xD800) && (n <= 0xDBFF))) {
1528 /* Allow a surrogate-pair-like encoding, as long as
1529 the next part is "\uD..." */
1530 int n2 = -1, sndp = 0;
1531 mzchar snd[7];
1532 ch = scheme_getc(port);
1533 if (ch == '\\') {
1534 snd[sndp++] = ch;
1535 ch = scheme_getc(port);
1536 if (ch == 'u') {
1537 snd[sndp++] = ch;
1538 ch = scheme_getc(port);
1539 if ((ch == 'd') || (ch == 'D')) {
1540 snd[sndp++] = ch;
1541 ch = scheme_getc(port);
1542 if (NOT_EOF_OR_SPECIAL(ch) && scheme_isxdigit(ch)) {
1543 snd[sndp++] = ch;
1544 n2 = (scheme_toupper(ch)-'A'+10);
1545 if ((n2 >= 12) && (n2 <= 15)) {
1546 n2 = 0xD000 | (n2 << 8);
1547 ch = scheme_getc(port);
1548 if (NOT_EOF_OR_SPECIAL(ch) && scheme_isxdigit(ch)) {
1549 snd[sndp++] = ch;
1550 n2 |= ((ch<='9' ? ch-'0' : (scheme_toupper(ch)-'A'+10)) << 4);
1551 ch = scheme_getc(port);
1552 if (NOT_EOF_OR_SPECIAL(ch) && scheme_isxdigit(ch)) {
1553 n2 |= (ch<='9' ? ch-'0' : (scheme_toupper(ch)-'A'+10));
1554 n = (((n - 0xD800) << 10) + (n2 - 0xDC00)) + 0x10000;
1555 } else
1556 n2 = -1;
1557 } else
1558 n2 = -1;
1559 } else
1560 n2 = -1;
1561 }
1562 }
1563 }
1564 }
1565 if (n2 < 0) {
1566 if (NOT_EOF_OR_SPECIAL(ch))
1567 snd[sndp++] = ch;
1568 snd[sndp] = 0;
1569 if (err_ok)
1570 scheme_read_err(port,
1571 "read: bad or incomplete surrogate-style encoding at `\\u%s%5'",
1572 initial,
1573 snd);
1574 return NULL;
1575 }
1576 }
1577 /* disallow surrogate points, etc */
1578 if (((n >= 0xD800) && (n <= 0xDFFF))
1579 || (n > 0x10FFFF)) {
1580 ch = -1;
1581 } else {
1582 ch = n;
1583 }
1584 } else {
1585 if (err_ok)
1586 scheme_read_err(port,
1587 "read: no hex digit following \\%c in %s",
1588 ((maxc == 4) ? 'u' : 'U'),
1589 "string");
1590 return NULL;
1591 }
1592 break;
1593 } /* else FALLTHROUGH!!! */
1594 default:
1595 if ((ch >= '0') && (ch <= '7')) {
1596 for (n = j = 0; j < 3; j++) {
1597 n1 = 8*n + ch - '0';
1598 if (n1 > 255) {
1599 if (err_ok)
1600 scheme_read_err(port,
1601 "read: escape sequence \\%o out of range in %s", n1,
1602 "string");
1603 return NULL;
1604 }
1605 n = n1;
1606 if (j < 2) {
1607 ch = scheme_peekc(port);
1608 if (!((ch >= '0') && (ch <= '7'))) {
1609 break;
1610 } else {
1611 scheme_getc(port); /* must be ch */
1612 }
1613 }
1614 }
1615 ch = n;
1616 } else {
1617 if (err_ok)
1618 scheme_read_err(port,
1619 "read: unknown escape sequence \\%c in %s%s", ch,
1620 is_byte ? "byte " : "",
1621 "string");
1622 return NULL;
1623 }
1624 break;
1625 }
1626 } else if (is_byte && (ch > 255)) {
1627 if (err_ok)
1628 scheme_read_err(port,
1629 "read: out-of-range character in byte string: %c",
1630 ch);
1631 return NULL;
1632 }
1633
1634 if (ch < 0) {
1635 if (err_ok)
1636 scheme_read_err(port,
1637 "read: out-of-range character in %sstring",
1638 is_byte ? "byte " : "");
1639 return NULL;
1640 }
1641
1642 if (i >= size) {
1643 oldsize = size;
1644 oldbuf = buf;
1645
1646 size *= 2;
1647 buf = (mzchar *)scheme_malloc_atomic((size + 1) * sizeof(mzchar));
1648 memcpy(buf, oldbuf, oldsize * sizeof(mzchar));
1649 }
1650 buf[i++] = ch;
1651 }
1652 buf[i] = '\0';
1653
1654 if (!is_byte)
1655 result = scheme_make_immutable_sized_char_string(buf, i, i <= 31);
1656 else {
1657 /* buf is not UTF-8 encoded; all of the chars are less than 256.
1658 We just need to change to bytes.. */
1659 char *s;
1660 s = (char *)scheme_malloc_atomic(i + 1);
1661 for (j = 0; j < i; j++) {
1662 ((unsigned char *)s)[j] = buf[j];
1663 }
1664 s[i] = 0;
1665 result = scheme_make_immutable_sized_byte_string(s, i, 0);
1666 }
1667
1668 return result;
1669 }
1670
scheme_read_byte_string(Scheme_Object * port)1671 Scheme_Object *scheme_read_byte_string(Scheme_Object *port)
1672 /* used by GRacket */
1673 {
1674 return read_string(1, port, NULL, 0);
1675 }
1676
1677 /*========================================================================*/
1678 /* vector reader */
1679 /*========================================================================*/
1680
1681 /* "#(" has been read */
1682 static Scheme_Object *
read_vector(Scheme_Object * port,int opener,char closer,ReadParams * params,int allow_infix)1683 read_vector (Scheme_Object *port,
1684 int opener, char closer,
1685 ReadParams *params,
1686 int allow_infix)
1687 {
1688 Scheme_Object *lresult, *obj;
1689 Scheme_Object *vec;
1690 int len, i;
1691
1692 lresult = read_list(port, opener, closer,
1693 (allow_infix ? mz_shape_vec_plus_infix : mz_shape_vec),
1694 1, params);
1695
1696 obj = lresult;
1697
1698 len = scheme_list_length(obj);
1699
1700 vec = (Scheme_Object *) scheme_make_vector(len, NULL);
1701 for (i = 0; i < len ; i++) {
1702 SCHEME_VEC_ELS(vec)[i] = SCHEME_CAR(obj);
1703 obj = SCHEME_CDR(obj);
1704 }
1705
1706 return vec;
1707 }
1708
1709 /*========================================================================*/
1710 /* symbol reader */
1711 /*========================================================================*/
1712
1713 /* Also dispatches to number reader, since things not-a-number are
1714 symbols. */
1715
1716 typedef int (*Getc_Fun_r)(Scheme_Object *port);
1717
1718 /* nothing has been read, except maybe some flags */
1719 static Scheme_Object *
read_number_or_symbol(int init_ch,Scheme_Object * port,int is_float,int is_not_float,int radix,int radix_set,int is_symbol,int is_kw,ReadParams * params)1720 read_number_or_symbol(int init_ch, Scheme_Object *port,
1721 int is_float, int is_not_float,
1722 int radix, int radix_set,
1723 int is_symbol, int is_kw,
1724 ReadParams *params)
1725 {
1726 mzchar *buf, *oldbuf, onstack[MAX_QUICK_SYMBOL_SIZE];
1727 int size, oldsize;
1728 int i, ch, quoted_ever = 0, running_quote = 0;
1729 int running_quote_ch = 0;
1730 Scheme_Object *o;
1731 int delim_ok;
1732 int ungetc_ok;
1733 int far_char_ok;
1734 int single_escape, multiple_escape;
1735 Getc_Fun_r getc_fun;
1736
1737 ungetc_ok = scheme_peekc_is_ungetc(port);
1738
1739 if (ungetc_ok)
1740 getc_fun = scheme_getc;
1741 else
1742 getc_fun = scheme_peekc;
1743
1744 i = 0;
1745 size = MAX_QUICK_SYMBOL_SIZE - 1;
1746 buf = onstack;
1747
1748 if (init_ch < 0)
1749 ch = getc_fun(port);
1750 else {
1751 /* Assert: this one won't need to be ungotten */
1752 ch = init_ch;
1753 }
1754
1755 delim_ok = SCHEME_OK;
1756 far_char_ok = 1;
1757
1758 while (NOT_EOF_OR_SPECIAL(ch)
1759 && (running_quote
1760 || (!scheme_isspace(ch)
1761 && (((ch < 128) && (delim[ch] & delim_ok))
1762 || ((ch >= 128) && far_char_ok))))) {
1763 single_escape = (ch == '\\');
1764 multiple_escape = (ch == '|');
1765 if (!ungetc_ok) {
1766 if (init_ch < 0)
1767 scheme_getc(port); /* must be a character */
1768 else
1769 init_ch = -1;
1770 }
1771 if (single_escape && !running_quote) {
1772 int esc_ch = ch;
1773 ch = scheme_getc(port);
1774 if (ch == EOF) {
1775 scheme_read_err(port, "read: EOF following `%c' in %s", esc_ch, is_kw ? "keyword" : "symbol");
1776 return NULL;
1777 }
1778 quoted_ever = 1;
1779 } else if (multiple_escape && (!running_quote || (ch == running_quote_ch))) {
1780 quoted_ever = 1;
1781 running_quote = !running_quote;
1782 running_quote_ch = ch;
1783
1784 ch = getc_fun(port);
1785 continue; /* <-- !!! */
1786 }
1787
1788 if (i >= size) {
1789 oldsize = size;
1790 oldbuf = buf;
1791
1792 size *= 2;
1793 buf = (mzchar *)scheme_malloc_atomic((size + 1) * sizeof(mzchar));
1794 memcpy(buf, oldbuf, oldsize * sizeof(mzchar));
1795 }
1796
1797 buf[i++] = ch;
1798
1799 ch = getc_fun(port);
1800 }
1801
1802 if (ungetc_ok)
1803 scheme_ungetc(ch, port);
1804
1805 if (running_quote) {
1806 scheme_read_err(port, "read: unbalanced `%c`", running_quote_ch);
1807 return NULL;
1808 }
1809
1810 buf[i] = '\0';
1811
1812 if (!quoted_ever && (i == 1) && (buf[0] == '.')) {
1813 intptr_t xl, xc, xp;
1814 scheme_tell_all(port, &xl, &xc, &xp);
1815 scheme_read_err(port, "read: illegal use of `.'");
1816 return NULL;
1817 }
1818
1819 if ((is_symbol || quoted_ever) && !is_float && !is_not_float && !radix_set)
1820 o = scheme_false;
1821 else {
1822 o = scheme_read_number(buf, i,
1823 is_float, is_not_float, 1 /* decimal_inexact */,
1824 radix, radix_set,
1825 port, NULL, 0);
1826 }
1827
1828 if (SAME_OBJ(o, scheme_false)) {
1829 if (is_kw)
1830 o = scheme_intern_exact_char_keyword(buf, i);
1831 else
1832 o = scheme_intern_exact_char_symbol(buf, i);
1833 }
1834
1835 return o;
1836 }
1837
1838 static Scheme_Object *
read_number(int init_ch,Scheme_Object * port,int is_float,int is_not_float,int radix,int radix_set,ReadParams * params)1839 read_number(int init_ch,
1840 Scheme_Object *port,
1841 int is_float, int is_not_float,
1842 int radix, int radix_set,
1843 ReadParams *params)
1844 {
1845 return read_number_or_symbol(init_ch,
1846 port,
1847 is_float, is_not_float,
1848 radix, radix_set, 0, 0,
1849 params);
1850 }
1851
1852 static Scheme_Object *
read_symbol(int init_ch,Scheme_Object * port,ReadParams * params)1853 read_symbol(int init_ch,
1854 Scheme_Object *port,
1855 ReadParams *params)
1856 {
1857 return read_number_or_symbol(init_ch,
1858 port,
1859 0, 0, 10, 0, 1, 0,
1860 params);
1861 }
1862
1863 static Scheme_Object *
read_keyword(int init_ch,Scheme_Object * port,ReadParams * params)1864 read_keyword(int init_ch,
1865 Scheme_Object *port,
1866 ReadParams *params)
1867 {
1868 return read_number_or_symbol(init_ch,
1869 port,
1870 0, 0, 10, 0, 1, 1,
1871 params);
1872 }
1873
1874 static Scheme_Object *
read_delimited_constant(int ch,const mzchar * str,Scheme_Object * v,Scheme_Object * port,ReadParams * params)1875 read_delimited_constant(int ch, const mzchar *str,
1876 Scheme_Object *v,
1877 Scheme_Object *port,
1878 ReadParams *params)
1879 {
1880 int first_ch = ch;
1881 int scanpos = 1;
1882
1883 if (ch == str[0]) { /* might be `T' instead of `t', for example */
1884 do {
1885 ch = scheme_getc(port);
1886 if ((mzchar)ch == str[scanpos]) {
1887 scanpos++;
1888 } else {
1889 break;
1890 }
1891 } while (str[scanpos]);
1892 } else {
1893 /* need to show next character to show why it's wrong: */
1894 ch = scheme_getc(port);
1895 }
1896
1897 if (str[scanpos]
1898 || !next_is_delim(port)) {
1899 mzchar str_part[7], one_more[2];
1900
1901 if (!str[scanpos]) {
1902 /* get non-delimiter again: */
1903 ch = scheme_getc(port);
1904 }
1905
1906 memcpy(str_part, str XFORM_OK_PLUS 1, (scanpos - 1) * sizeof(mzchar));
1907 str_part[scanpos - 1] = 0;
1908 if (NOT_EOF_OR_SPECIAL(ch)) {
1909 one_more[0] = ch;
1910 one_more[1] = 0;
1911 } else
1912 one_more[0] = 0;
1913
1914 scheme_read_err(port,
1915 "read: bad syntax `#%c%5%u'",
1916 first_ch,
1917 str_part,
1918 one_more,
1919 (intptr_t)(NOT_EOF_OR_SPECIAL(ch) ? 1 : 0));
1920 return NULL;
1921 }
1922
1923 return v;
1924 }
1925
1926 /*========================================================================*/
1927 /* char reader */
1928 /*========================================================================*/
1929
u_strcmp(mzchar * s,const char * _t)1930 static int u_strcmp(mzchar *s, const char *_t)
1931 {
1932 int i;
1933 unsigned char *t = (unsigned char *)_t;
1934
1935 for (i = 0; s[i] && (scheme_tolower(s[i]) == scheme_tolower((mzchar)((unsigned char *)t)[i])); i++) {
1936 }
1937 if (s[i] || t[i])
1938 return 1;
1939 return 0;
1940 }
1941
make_interned_char(int ch,int intern)1942 static Scheme_Object *make_interned_char(int ch, int intern)
1943 {
1944 if (ch < 256)
1945 return scheme_make_character(ch);
1946 else if (intern)
1947 return scheme_intern_literal_number(scheme_make_char(ch));
1948 else
1949 return scheme_make_char(ch);
1950 }
1951
1952 /* "#\" has been read */
1953 static Scheme_Object *
read_character(Scheme_Object * port,ReadParams * params)1954 read_character(Scheme_Object *port,
1955 ReadParams *params)
1956 {
1957 int ch, next;
1958
1959 ch = scheme_getc(port);
1960
1961 next = scheme_peekc(port);
1962
1963 if ((ch >= '0' && ch <= '7') && (next >= '0' && next <= '7')) {
1964 /* a is the same as next */
1965 int last;
1966
1967 last = (scheme_getc(port) /* is char */, scheme_peekc(port));
1968
1969 if (last != SCHEME_SPECIAL)
1970 scheme_getc(port); /* must be last */
1971
1972 if (last < '0' || last > '7' || ch > '3') {
1973 scheme_read_err(port,
1974 "read: bad character constant #\\%c%c%c",
1975 ch, next, ((last == EOF) || (last == SCHEME_SPECIAL)) ? ' ' : last);
1976 return NULL;
1977 }
1978
1979 ch = ((ch - '0') << 6) + ((next - '0') << 3) + (last - '0');
1980
1981 return make_interned_char(ch, 0);
1982 }
1983
1984 if (((ch == 'u') || (ch == 'U')) && NOT_EOF_OR_SPECIAL(next) && scheme_isxdigit(next)) {
1985 int count = 0, n = 0, nbuf[10], maxc = ((ch == 'u') ? 4 : 8);
1986 while (count < maxc) {
1987 ch = scheme_peekc(port);
1988 if (NOT_EOF_OR_SPECIAL(ch) && scheme_isxdigit(ch)) {
1989 nbuf[count] = ch;
1990 n = ((unsigned)n<<4) + (ch<='9' ? ch-'0' : (scheme_toupper(ch)-'A'+10));
1991 scheme_getc(port); /* must be ch */
1992 count++;
1993 } else
1994 break;
1995 }
1996 /* disallow surrogate points, etc. */
1997 if ((n < 0)
1998 || ((n >= 0xD800) && (n <= 0xDFFF))
1999 || (n > 0x10FFFF)) {
2000 scheme_read_err(port,
2001 "read: bad character constant #\\%c%u",
2002 (maxc == 4) ? 'u' : 'U',
2003 nbuf, (intptr_t)count);
2004 return NULL;
2005 } else {
2006 ch = n;
2007 }
2008 } else if ((ch != EOF) && scheme_isalpha(ch) && NOT_EOF_OR_SPECIAL(next) && scheme_isalpha(next)) {
2009 mzchar *buf, *oldbuf, onstack[32];
2010 int i;
2011 intptr_t size = 31, oldsize;
2012
2013 i = 1;
2014 buf = onstack;
2015 buf[0] = ch;
2016 while ((ch = scheme_peekc(port), NOT_EOF_OR_SPECIAL(ch) && scheme_isalpha(ch))) {
2017 scheme_getc(port); /* is alpha character */
2018 if (i >= size) {
2019 oldsize = size;
2020 oldbuf = buf;
2021
2022 size *= 2;
2023 buf = (mzchar *)scheme_malloc_atomic((size + 1) * sizeof(mzchar));
2024 memcpy(buf, oldbuf, oldsize * sizeof(mzchar));
2025 }
2026 buf[i++] = ch;
2027 }
2028 buf[i] = '\0';
2029
2030 switch (scheme_tolower(buf[0])) {
2031 case 'n': /* maybe `newline' or 'null' or 'nul' */
2032 if (!u_strcmp(buf, "newline"))
2033 return scheme_make_char('\n');
2034 if (!u_strcmp(buf, "null") || !u_strcmp(buf, "nul"))
2035 return scheme_make_char('\0');
2036 break;
2037 case 's': /* maybe `space' */
2038 if (!u_strcmp(buf, "space"))
2039 return scheme_make_char(' ');
2040 break;
2041 case 'r': /* maybe `rubout' or `return' */
2042 if (!u_strcmp(buf, "rubout"))
2043 return scheme_make_char(0x7f);
2044 if (!u_strcmp(buf, "return"))
2045 return scheme_make_char('\r');
2046 break;
2047 case 'p': /* maybe `page' */
2048 if (!u_strcmp(buf, "page"))
2049 return scheme_make_char('\f');
2050 break;
2051 case 't': /* maybe `tab' */
2052 if (!u_strcmp(buf, "tab"))
2053 return scheme_make_char('\t');
2054 break;
2055 case 'v': /* maybe `vtab' */
2056 if (!u_strcmp(buf, "vtab"))
2057 return scheme_make_char(0xb);
2058 break;
2059 case 'b': /* maybe `backspace' */
2060 if (!u_strcmp(buf, "backspace"))
2061 return scheme_make_char('\b');
2062 break;
2063 case 'l': /* maybe `linefeed' */
2064 if (!u_strcmp(buf, "linefeed"))
2065 return scheme_make_char('\n');
2066 break;
2067 default:
2068 break;
2069 }
2070
2071 scheme_read_err(port, "read: bad character constant: #\\%5", buf);
2072 }
2073
2074 if (ch == EOF)
2075 scheme_read_err(port, "read: expected a character after #\\");
2076
2077 return make_interned_char(ch, 0);
2078 }
2079
2080 /*========================================================================*/
2081 /* quote readers */
2082 /*========================================================================*/
2083
2084 /* "'", etc. has been read */
2085 static Scheme_Object *
read_quote(char * who,Scheme_Object * quote_symbol,int len,Scheme_Object * port,ReadParams * params)2086 read_quote(char *who, Scheme_Object *quote_symbol, int len,
2087 Scheme_Object *port, ReadParams *params)
2088 {
2089 Scheme_Object *obj, *ret;
2090
2091 obj = read_inner(port, params, -1);
2092 if (SCHEME_EOFP(obj))
2093 scheme_read_err(port, "read: expected an element for %s (found end-of-file)", who);
2094 ret = quote_symbol;
2095 ret = scheme_make_pair(ret, scheme_make_pair(obj, scheme_null));
2096 return ret;
2097 }
2098
2099 /* "#&" has been read */
read_box(Scheme_Object * port,ReadParams * params)2100 static Scheme_Object *read_box(Scheme_Object *port, ReadParams *params)
2101 {
2102 Scheme_Object *o, *bx;
2103
2104 o = read_inner(port, params, -1);
2105
2106 if (SCHEME_EOFP(o))
2107 scheme_read_err(port, "read: expected an element for #& box (found end-of-file)");
2108
2109 bx = scheme_box(o);
2110
2111 return bx;
2112 }
2113
2114 /*========================================================================*/
2115 /* hash table reader */
2116 /*========================================================================*/
2117
2118 /* "(" has been read */
read_hash(Scheme_Object * port,int opener,char closer,int kind,ReadParams * params)2119 static Scheme_Object *read_hash(Scheme_Object *port,
2120 int opener, char closer, int kind,
2121 ReadParams *params)
2122 {
2123 Scheme_Object *l;
2124 Scheme_Object *key, *val;
2125 Scheme_Hash_Tree *t;
2126
2127 /* using mz_shape_hash_list ensures that l is a list of pairs */
2128 l = read_list(port, opener, closer, mz_shape_hash_list, 0, params);
2129
2130 t = scheme_make_hash_tree(kind);
2131
2132 for (; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) {
2133 val = SCHEME_STX_CAR(l);
2134 key = SCHEME_STX_CAR(val);
2135 key = scheme_syntax_to_datum(key);
2136 key = scheme_expander_syntax_to_datum(key);
2137 val = SCHEME_STX_CDR(val);
2138
2139 t = scheme_hash_tree_set(t, key, val);
2140 }
2141
2142 return (Scheme_Object *)t;
2143 }
2144
2145 /*========================================================================*/
2146 /* intern */
2147 /*========================================================================*/
2148
read_intern(int argc,Scheme_Object ** argv)2149 static Scheme_Object *read_intern(int argc, Scheme_Object **argv)
2150 {
2151 return scheme_read_intern(argv[0]);
2152 }
2153
scheme_read_intern(Scheme_Object * o)2154 Scheme_Object *scheme_read_intern(Scheme_Object *o)
2155 {
2156 if (!SCHEME_INTP(o) && SCHEME_NUMBERP(o))
2157 o = scheme_intern_literal_number(o);
2158 else if (SCHEME_CHAR_STRINGP(o)) {
2159 if (!SCHEME_IMMUTABLEP(o))
2160 o = scheme_make_immutable_sized_char_string(SCHEME_CHAR_STR_VAL(o),
2161 SCHEME_CHAR_STRLEN_VAL(o),
2162 1);
2163 o = scheme_intern_literal_string(o);
2164 } else if (SCHEME_BYTE_STRINGP(o)) {
2165 if (!SCHEME_IMMUTABLEP(o))
2166 o = scheme_make_immutable_sized_byte_string(SCHEME_BYTE_STR_VAL(o),
2167 SCHEME_BYTE_STRLEN_VAL(o),
2168 1);
2169 o = scheme_intern_literal_string(o);
2170 } else if (SAME_TYPE(SCHEME_TYPE(o), scheme_regexp_type))
2171 o = scheme_intern_literal_string(o);
2172 else if (SCHEME_CHARP(o) && (SCHEME_CHAR_VAL(o) >= 256))
2173 o = scheme_intern_literal_number(o);
2174
2175 return o;
2176 }
2177
2178 /*========================================================================*/
2179 /* utilities */
2180 /*========================================================================*/
2181
2182 static int
skip_whitespace_comments(Scheme_Object * port,ReadParams * params)2183 skip_whitespace_comments(Scheme_Object *port,
2184 ReadParams *params)
2185 {
2186 int ch;
2187
2188 start_over:
2189
2190 while ((ch = scheme_getc(port), NOT_EOF_OR_SPECIAL(ch) && scheme_isspace(ch))) {}
2191
2192 if (ch == ';') {
2193 do {
2194 ch = scheme_getc(port);
2195 } while (!is_line_comment_end(ch) && (ch != EOF));
2196 goto start_over;
2197 }
2198
2199 if ((ch == '#')
2200 && (scheme_peekc(port) == '|')) {
2201 int depth = 0;
2202 int ch2 = 0;
2203
2204 (void)scheme_getc(port); /* re-read '|' */
2205 do {
2206 ch = scheme_getc(port);
2207
2208 if (ch == EOF)
2209 scheme_read_err(port, "read: end of file in #| comment");
2210
2211 if ((ch2 == '|') && (ch == '#')) {
2212 if (!(depth--))
2213 goto start_over;
2214 ch = 0; /* So we don't count '#' toward an opening "#|" */
2215 } else if ((ch2 == '#') && (ch == '|')) {
2216 depth++;
2217 ch = 0; /* So we don't count '|' toward a closing "|#" */
2218 }
2219 ch2 = ch;
2220 } while (1);
2221
2222 goto start_over;
2223 }
2224 if ((ch == '#')
2225 && (scheme_peekc(port) == ';')) {
2226 Scheme_Object *skipped;
2227
2228 (void)scheme_getc(port); /* re-read ';' */
2229
2230 skipped = read_inner(port, params, -1);
2231 if (SCHEME_EOFP(skipped))
2232 scheme_read_err(port, "read: expected a commented-out element for `#;' (found end-of-file)");
2233
2234 goto start_over;
2235 }
2236
2237 return ch;
2238 }
2239
unexpected_closer(int ch,Scheme_Object * port)2240 static void unexpected_closer(int ch, Scheme_Object *port)
2241 {
2242 scheme_read_err(port, "read: unexpected `%c`", ch);
2243 }
2244
read_graph_index(Scheme_Object * port,int * ch)2245 static int read_graph_index(Scheme_Object *port, int *ch)
2246 {
2247 int digits = 0, val = 0, nch;
2248
2249 while (NOT_EOF_OR_SPECIAL((*ch)) && isdigit_ascii((*ch))) {
2250 if (digits >= MAX_GRAPH_ID_DIGITS)
2251 scheme_read_err(port, "too many digits after `#%d`", val);
2252 digits++;
2253
2254 val = ((val) * 10) + ((*ch) - 48);
2255 nch = scheme_getc(port);
2256 (*ch) = nch;
2257 }
2258
2259 return val;
2260 }
2261
2262 /*========================================================================*/
2263 /* .zo reader */
2264 /*========================================================================*/
2265
2266 #define ZO_CHECK(x) if (!(x)) scheme_ill_formed_code(port);
2267 #define RANGE_CHECK(x, y) ZO_CHECK (x y)
2268 #define RANGE_POS_CHECK(x, y) ZO_CHECK ((x > 0) && (x y))
2269 #define RANGE_CHECK_GETS(x) RANGE_CHECK(x, <= port->size - port->pos)
2270
2271 typedef struct CPort {
2272 MZTAG_IF_REQUIRED
2273 uintptr_t pos, size;
2274 unsigned char *start;
2275 uintptr_t symtab_size;
2276 intptr_t base;
2277 int unsafe_ok;
2278 Scheme_Object *orig_port;
2279 Scheme_Hash_Table **ht;
2280 Scheme_Object *symtab_refs;
2281 Scheme_Unmarshal_Tables *ut;
2282 Scheme_Object **symtab;
2283 Scheme_Hash_Table *symtab_entries;
2284 Scheme_Object *relto;
2285 intptr_t *shared_offsets;
2286 Scheme_Load_Delay *delay_info;
2287 mzlonglong bytecode_hash;
2288 } CPort;
2289 #define CP_GETC(cp) ((int)(cp->start[cp->pos++]))
2290 #define CP_UNGETC(cp) --cp->pos
2291 #define CP_TELL(port) (port->pos + port->base)
2292
2293 typedef void *(*GC_Alloc_Proc)(size_t);
2294
2295 static Scheme_Object *read_compact_list(int c, int proper, int use_stack, CPort *port);
2296 static Scheme_Object *read_compact_quote(CPort *port, int embedded);
2297
scheme_ill_formed(struct CPort * port,const char * file,int line)2298 void scheme_ill_formed(struct CPort *port
2299 #if TRACK_ILL_FORMED_CATCH_LINES
2300 , const char *file, int line
2301 #endif
2302 )
2303 {
2304 scheme_read_err(port ? port->orig_port : NULL,
2305 "read (compiled): ill-formed code"
2306 #if TRACK_ILL_FORMED_CATCH_LINES
2307 " [%s:%d]", file, line
2308 #endif
2309 );
2310 }
2311
make_ut(CPort * port)2312 static void make_ut(CPort *port)
2313 {
2314 Scheme_Unmarshal_Tables *ut;
2315 char *decoded;
2316
2317 ut = MALLOC_ONE_RT(Scheme_Unmarshal_Tables);
2318 SET_REQUIRED_TAG(ut->type = scheme_rt_unmarshal_info);
2319 port->ut = ut;
2320 ut->rp = port;
2321 if (port->delay_info)
2322 port->delay_info->ut = ut;
2323
2324 decoded = (char *)scheme_malloc_atomic(port->symtab_size);
2325 memset(decoded, 0, port->symtab_size);
2326 ut->decoded = decoded;
2327
2328 ut->bytecode_hash = port->bytecode_hash;
2329 }
2330
2331 /* Since read_compact_number is called often, we want it to be
2332 a cheap call in 3m, so avoid anything that allocated --- even
2333 error reporting, since we can make up a valid number. */
2334 #define NUM_ZO_CHECK(x) if (!(x)) return 0;
2335
read_compact_number(CPort * port)2336 XFORM_NONGCING static intptr_t read_compact_number(CPort *port)
2337 {
2338 intptr_t flag, v, a, b, c, d;
2339
2340 NUM_ZO_CHECK(port->pos < port->size);
2341
2342 flag = CP_GETC(port);
2343
2344 if (flag < 128)
2345 return flag;
2346 else if (!(flag & 0x40)) {
2347 NUM_ZO_CHECK(port->pos < port->size);
2348
2349 a = CP_GETC(port);
2350
2351 v = (flag & 0x3F)
2352 + (a << 6);
2353 return v;
2354 } else if (!(flag & 0x20)) {
2355 return -(flag & 0x1F);
2356 }
2357
2358 NUM_ZO_CHECK(port->pos + 3 < port->size);
2359
2360 a = CP_GETC(port);
2361 b = CP_GETC(port);
2362 c = CP_GETC(port);
2363 d = CP_GETC(port);
2364
2365 v = a
2366 + (b << 8)
2367 + (c << 16)
2368 + (d << 24);
2369
2370 if (flag & 0x10)
2371 return v;
2372 else
2373 return -v;
2374 }
2375
read_compact_chars(CPort * port,char * buffer,int bsize,int l)2376 static char *read_compact_chars(CPort *port,
2377 char *buffer,
2378 int bsize, int l)
2379 {
2380 /* Range check is performed before the function is called. */
2381 char *s;
2382
2383 if (l < bsize)
2384 s = buffer;
2385 else
2386 s = (char *)scheme_malloc_atomic(l + 1);
2387
2388 memcpy(s, port->start + port->pos, l);
2389 port->pos += l;
2390
2391 s[l] = 0;
2392
2393 return s;
2394 }
2395
read_compact_svector(CPort * port,int l)2396 static Scheme_Object *read_compact_svector(CPort *port, int l)
2397 {
2398 Scheme_Object *o;
2399 mzshort *v;
2400
2401 o = scheme_alloc_object();
2402 o->type = scheme_svector_type;
2403
2404 SCHEME_SVEC_LEN(o) = l;
2405 if (l > 0) {
2406 if (l > 4096) {
2407 v = (mzshort *)scheme_malloc_fail_ok(scheme_malloc_atomic,
2408 scheme_check_overflow(l, sizeof(mzshort), 0));
2409 if (!v)
2410 scheme_signal_error("out of memory allocating vector");
2411 } else {
2412 v = MALLOC_N_ATOMIC(mzshort, l);
2413 }
2414 } else {
2415 v = NULL;
2416 l = 0; /* in case it was negative */
2417 }
2418 SCHEME_SVEC_VEC(o) = v;
2419
2420 while (l-- > 0) {
2421 mzshort cn;
2422 cn = read_compact_number(port);
2423 v[l] = cn;
2424 }
2425
2426 return o;
2427 }
2428
valid_utf8(const char * s,int l)2429 static int valid_utf8(const char *s, int l)
2430 {
2431 return (scheme_utf8_decode((const unsigned char *)s, 0, l, NULL, 0, -1, NULL, 0, 0) >= 0);
2432 }
2433
2434
read_escape_from_string(char * s,intptr_t len,Scheme_Object * rel_to,Scheme_Hash_Table ** ht,Scheme_Object * orig_port)2435 static Scheme_Object *read_escape_from_string(char *s, intptr_t len,
2436 Scheme_Object *rel_to,
2437 Scheme_Hash_Table **ht,
2438 Scheme_Object *orig_port)
2439 {
2440 Scheme_Object *ep, *v;
2441 ReadParams params;
2442 Scheme_Input_Port *ep_ip;
2443
2444 ep = scheme_make_sized_byte_string_input_port(s, len);
2445
2446 if (orig_port) {
2447 v = scheme_input_port_record(orig_port)->name;
2448 if (v) {
2449 ep_ip = scheme_input_port_record(ep);
2450 ep_ip->name = v;
2451 }
2452 }
2453
2454 params.skip_zo_vers_check = 0;
2455 params.read_relative_path = rel_to;
2456 params.graph_ht = *ht;
2457
2458 v = read_inner(ep, ¶ms, -1);
2459
2460 *ht = params.graph_ht;
2461
2462 return v;
2463 }
2464
read_compact_escape(CPort * port)2465 static Scheme_Object *read_compact_escape(CPort *port)
2466 {
2467 #if defined(MZ_PRECISE_GC)
2468 # define ESC_BLK_BUF_SIZE 32
2469 char buffer[ESC_BLK_BUF_SIZE];
2470 #endif
2471 int len;
2472 char *s;
2473
2474 len = read_compact_number(port);
2475
2476 RANGE_CHECK_GETS((unsigned)len);
2477
2478 #if defined(MZ_PRECISE_GC)
2479 s = read_compact_chars(port, buffer, ESC_BLK_BUF_SIZE, len);
2480 if (s != buffer)
2481 len = -len; /* no alloc in sized_byte_string_input_port */
2482 #else
2483 s = (char *)port->start + port->pos;
2484 port->pos += len;
2485 len = -len; /* no alloc in sized_byte_string_input_port */
2486 #endif
2487
2488 return read_escape_from_string(s, len, port->relto, port->ht, port->orig_port);
2489 }
2490
record_symtab_self_contained(Scheme_Hash_Table * symtab_entries,Scheme_Object * v)2491 static void record_symtab_self_contained(Scheme_Hash_Table *symtab_entries, Scheme_Object *v)
2492 {
2493 if (SCHEME_PAIRP(v)
2494 || SCHEME_BOXP(v)
2495 || SCHEME_VECTORP(v)
2496 || SCHEME_HASHTRP(v)
2497 || SCHEME_STRUCTP(v)) {
2498 /* Register `v` as a value that is shared through the symbol table,
2499 so that later calls to resolve_references() can avoid re-traversing
2500 the value. (Otherwise, bytecode reading can become quadratic-time.) */
2501 scheme_hash_set(symtab_entries, v, scheme_true);
2502 }
2503 }
2504
resolve_symtab_refs(Scheme_Object * v,CPort * port)2505 static Scheme_Object *resolve_symtab_refs(Scheme_Object *v, CPort *port)
2506 {
2507 Scheme_Object *l;
2508
2509 if (SCHEME_NULLP(port->symtab_refs))
2510 return v;
2511
2512 if (v) {
2513 v = scheme_make_pair(v, port->symtab_refs);
2514
2515 v = resolve_references(v, port->orig_port,
2516 scheme_make_hash_table(SCHEME_hash_ptr),
2517 scheme_make_hash_table(SCHEME_hash_ptr),
2518 port->symtab_entries,
2519 0, 0);
2520
2521 l = SCHEME_CDR(v);
2522 } else
2523 l = port->symtab_refs;
2524
2525 for (; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
2526 if (v) {
2527 port->symtab[SCHEME_INT_VAL(SCHEME_CAR(SCHEME_CAR(l)))] = SCHEME_CDR(SCHEME_CAR(l));
2528 record_symtab_self_contained(port->symtab_entries, SCHEME_CDR(SCHEME_CAR(l)));
2529 } else {
2530 /* interrupted; discard partial constructions */
2531 port->symtab[SCHEME_INT_VAL(SCHEME_CAR(SCHEME_CAR(l)))] = NULL;
2532 }
2533 }
2534
2535 port->symtab_refs = scheme_null;
2536
2537 if (v)
2538 return SCHEME_CAR(v);
2539 else
2540 return NULL;
2541 }
2542
2543 static Scheme_Object *read_compact(CPort *port, int use_stack);
2544
read_compact_k(void)2545 static Scheme_Object *read_compact_k(void)
2546 {
2547 Scheme_Thread *p = scheme_current_thread;
2548 CPort *port = (CPort *)p->ku.k.p1;
2549
2550 p->ku.k.p1 = NULL;
2551
2552 return read_compact(port, p->ku.k.i1);
2553 }
2554
2555 /* never a valid symtab value: */
2556 #define SYMTAB_IN_PROGRESS SCHEME_MULTIPLE_VALUES
2557
read_compact(CPort * port,int use_stack)2558 static Scheme_Object *read_compact(CPort *port, int use_stack)
2559 {
2560 #define BLK_BUF_SIZE 32
2561 unsigned int l;
2562 char *s, buffer[BLK_BUF_SIZE];
2563 int ch;
2564 Scheme_Object *v;
2565
2566 #ifdef DO_STACK_CHECK
2567 {
2568 # include "mzstkchk.h"
2569 {
2570 Scheme_Thread *p = scheme_current_thread;
2571 p->ku.k.p1 = (void *)port;
2572 p->ku.k.i1 = use_stack;
2573 return scheme_handle_stack_overflow(read_compact_k);
2574 }
2575 }
2576 #endif
2577
2578 {
2579 ZO_CHECK(port->pos < port->size);
2580 ch = CP_GETC(port);
2581
2582 switch(cpt_branch[ch]) {
2583 case CPT_ESCAPE:
2584 v = read_compact_escape(port);
2585 break;
2586 case CPT_SYMBOL:
2587 l = read_compact_number(port);
2588 RANGE_CHECK_GETS(l);
2589 s = read_compact_chars(port, buffer, BLK_BUF_SIZE, l);
2590 if (!valid_utf8(s, l))
2591 scheme_ill_formed_code(port);
2592 v = scheme_intern_exact_symbol(s, l);
2593 break;
2594 case CPT_SYMREF:
2595 l = read_compact_number(port);
2596 RANGE_POS_CHECK(l, < port->symtab_size);
2597 v = port->symtab[l];
2598 if (v == SYMTAB_IN_PROGRESS) {
2599 /* there is a cycle */
2600 scheme_ill_formed_code(port);
2601 }
2602 if (!v) {
2603 intptr_t save_pos = port->pos;
2604 port->symtab[l] = SYMTAB_IN_PROGRESS; /* avoid cycles if marshaled form is broken: */
2605 port->pos = port->shared_offsets[l - 1];
2606 v = read_compact(port, 0);
2607 port->pos = save_pos;
2608 port->symtab[l] = v;
2609 }
2610 break;
2611 case CPT_WEIRD_SYMBOL:
2612 {
2613 int uninterned;
2614
2615 uninterned = read_compact_number(port);
2616
2617 l = read_compact_number(port);
2618 RANGE_CHECK_GETS(l);
2619 s = read_compact_chars(port, buffer, BLK_BUF_SIZE, l);
2620
2621 if (!valid_utf8(s, l))
2622 scheme_ill_formed_code(port);
2623
2624 if (uninterned)
2625 v = scheme_make_exact_symbol(s, l);
2626 else
2627 v = scheme_intern_exact_parallel_symbol(s, l);
2628
2629 /* The fact that all uses of the symbol go through the table
2630 means that uninterned symbols are consistently re-created for
2631 a particular compiled expression. */
2632 }
2633 break;
2634 case CPT_KEYWORD:
2635 l = read_compact_number(port);
2636 RANGE_CHECK_GETS(l);
2637 s = read_compact_chars(port, buffer, BLK_BUF_SIZE, l);
2638 if (!valid_utf8(s, l))
2639 scheme_ill_formed_code(port);
2640 v = scheme_intern_exact_keyword(s, l);
2641 break;
2642 case CPT_BYTE_STRING:
2643 l = read_compact_number(port);
2644 RANGE_CHECK_GETS(l);
2645 s = read_compact_chars(port, buffer, BLK_BUF_SIZE, l);
2646 v = scheme_make_immutable_sized_byte_string(s, l, l < BLK_BUF_SIZE);
2647 v = scheme_intern_literal_string(v);
2648 break;
2649 case CPT_CHAR_STRING:
2650 {
2651 unsigned int el;
2652 mzchar *us;
2653 el = read_compact_number(port);
2654 l = read_compact_number(port);
2655 RANGE_CHECK_GETS(el);
2656 s = read_compact_chars(port, buffer, BLK_BUF_SIZE, el);
2657 if (l < 4096)
2658 us = (mzchar *)scheme_malloc_atomic((l + 1) * sizeof(mzchar));
2659 else
2660 us = (mzchar *)scheme_malloc_fail_ok(scheme_malloc_atomic, (l + 1) * sizeof(mzchar));
2661 if (scheme_utf8_decode((const unsigned char *)s, 0, el, us, 0, l, NULL, 0, 0) != l)
2662 scheme_ill_formed_code(port);
2663 us[l] = 0;
2664 v = scheme_make_immutable_sized_char_string(us, l, 0);
2665 v = scheme_intern_literal_string(v);
2666 }
2667 break;
2668 case CPT_CHAR:
2669 l = read_compact_number(port);
2670 return make_interned_char(l, 1);
2671 break;
2672 case CPT_INT:
2673 return scheme_make_integer(read_compact_number(port));
2674 break;
2675 case CPT_NULL:
2676 return scheme_null;
2677 break;
2678 case CPT_TRUE:
2679 return scheme_true;
2680 break;
2681 case CPT_FALSE:
2682 return scheme_false;
2683 break;
2684 case CPT_VOID:
2685 return scheme_void;
2686 break;
2687 case CPT_BOX:
2688 v = scheme_box(read_compact(port, 0));
2689 SCHEME_SET_IMMUTABLE(v);
2690 break;
2691 case CPT_PAIR:
2692 {
2693 v = read_compact(port, 0);
2694 return scheme_make_pair(v, read_compact(port, 0));
2695 }
2696 break;
2697 case CPT_LIST:
2698 l = read_compact_number(port);
2699 if (l == 1) {
2700 v = read_compact(port, 0);
2701 return scheme_make_pair(v, read_compact(port, 0));
2702 } else
2703 return read_compact_list(l, 0, 0, port);
2704 break;
2705 case CPT_VECTOR:
2706 {
2707 Scheme_Object *vec;
2708 unsigned int i;
2709
2710 l = read_compact_number(port);
2711 vec = scheme_make_vector(l, NULL);
2712
2713 for (i = 0; i < l; i++) {
2714 v = read_compact(port, 0);
2715 SCHEME_VEC_ELS(vec)[i] = v;
2716 }
2717
2718 SCHEME_SET_IMMUTABLE(vec);
2719
2720 return vec;
2721 }
2722 break;
2723 case CPT_HASH_TABLE:
2724 {
2725 Scheme_Hash_Tree *ht;
2726 int kind, len;
2727 Scheme_Object *k;
2728
2729 kind = read_compact_number(port);
2730 if ((kind < 0) || (kind > 2))
2731 scheme_ill_formed_code(port);
2732 len = read_compact_number(port);
2733
2734 ht = scheme_make_hash_tree(kind);
2735 while (len--) {
2736 k = read_compact(port, 0);
2737 v = read_compact(port, 0);
2738 ht = scheme_hash_tree_set(ht, k, v);
2739 }
2740
2741 v = (Scheme_Object *)ht;
2742 }
2743 break;
2744 case CPT_LINKLET:
2745 {
2746 int has_prefix;
2747 Scheme_Prefix *pf;
2748
2749 has_prefix = read_compact_number(port);
2750 if (has_prefix)
2751 pf = (Scheme_Prefix *)read_compact(port, 0);
2752 else
2753 pf = NULL;
2754
2755 v = read_compact(port, 1);
2756 v = scheme_read_linklet(v, port->unsafe_ok);
2757 if (!v) scheme_ill_formed_code(port);
2758
2759 ((Scheme_Linklet *)v)->static_prefix = pf;
2760
2761 return v;
2762 }
2763 break;
2764 case CPT_QUOTE:
2765 v = read_compact_quote(port, 1);
2766 break;
2767 case CPT_REFERENCE:
2768 l = read_compact_number(port);
2769 RANGE_CHECK(l, < EXPECTED_PRIM_COUNT);
2770 return variable_references[l];
2771 break;
2772 case CPT_TOPLEVEL:
2773 {
2774 int flags, pos, depth;
2775
2776 flags = read_compact_number(port);
2777 pos = read_compact_number(port);
2778 depth = read_compact_number(port);
2779
2780 if ((depth < 0) || (pos < 0))
2781 scheme_ill_formed_code(port);
2782
2783 return scheme_make_toplevel(depth, pos, flags & SCHEME_TOPLEVEL_FLAGS_MASK);
2784 }
2785 break;
2786 case CPT_LOCAL:
2787 {
2788 int p, flags;
2789 p = read_compact_number(port);
2790 if (p < 0) {
2791 p = -(p + 1);
2792 flags = read_compact_number(port);
2793 } else
2794 flags = 0;
2795 return scheme_make_local(scheme_local_type, p, flags);
2796 }
2797 break;
2798 case CPT_LOCAL_UNBOX:
2799 {
2800 int p, flags;
2801 p = read_compact_number(port);
2802 if (p < 0) {
2803 p = -(p + 1);
2804 flags = read_compact_number(port);
2805 } else
2806 flags = 0;
2807 return scheme_make_local(scheme_local_unbox_type, p, flags);
2808 }
2809 break;
2810 case CPT_SVECTOR:
2811 {
2812 int l;
2813 l = read_compact_number(port);
2814 v = read_compact_svector(port, l);
2815 }
2816 break;
2817 case CPT_APPLICATION:
2818 {
2819 int c, i;
2820 Scheme_App_Rec *a;
2821
2822 c = read_compact_number(port) + 1;
2823
2824 a = scheme_malloc_application(c);
2825 for (i = 0; i < c; i++) {
2826 v = read_compact(port, 1);
2827 a->args[i] = v;
2828 }
2829
2830 scheme_finish_application(a);
2831 return (Scheme_Object *)a;
2832 }
2833 break;
2834 case CPT_BEGIN:
2835 case CPT_BEGIN0:
2836 {
2837 Scheme_Sequence *seq;
2838 int i, count;
2839
2840 count = read_compact_number(port);
2841 if (count <= 0) scheme_ill_formed_code(port);
2842 seq = scheme_malloc_sequence(count);
2843 seq->so.type = ((ch == CPT_BEGIN) ? scheme_sequence_type : scheme_begin0_sequence_type);
2844 seq->count = count;
2845
2846 for (i = 0; i < count; i++) {
2847 v = read_compact(port, 1);
2848 seq->array[i] = v;
2849 }
2850
2851 return (Scheme_Object *)seq;
2852 }
2853 break;
2854 case CPT_LET_VALUE:
2855 {
2856 Scheme_Let_Value *lv;
2857 int c, p;
2858
2859 lv = (Scheme_Let_Value *)scheme_malloc_tagged(sizeof(Scheme_Let_Value));
2860 lv->iso.so.type = scheme_let_value_type;
2861
2862 c = read_compact_number(port);
2863 p = read_compact_number(port);
2864 if ((c < 0) || (p < 0)) scheme_ill_formed_code(port);
2865
2866 lv->count = c;
2867 lv->position = p;
2868 if (read_compact_number(port))
2869 SCHEME_LET_VALUE_AUTOBOX(lv) = 1;
2870 v = read_compact(port, 1);
2871 lv->value = v;
2872 v = read_compact(port, 1);
2873 lv->body = v;
2874
2875 return (Scheme_Object *)lv;
2876 }
2877 break;
2878 case CPT_LET_VOID:
2879 {
2880 Scheme_Let_Void *lv;
2881 int c;
2882
2883 lv = (Scheme_Let_Void *)scheme_malloc_tagged(sizeof(Scheme_Let_Void));
2884 lv->iso.so.type = scheme_let_void_type;
2885
2886 c = read_compact_number(port);
2887 if (c < 0) scheme_ill_formed_code(port);
2888
2889 lv->count = c;
2890 if (read_compact_number(port))
2891 SCHEME_LET_VOID_AUTOBOX(lv) = 1;
2892 v = read_compact(port, 1);
2893 lv->body = v;
2894
2895 return (Scheme_Object *)lv;
2896 }
2897 break;
2898 case CPT_LETREC:
2899 {
2900 Scheme_Letrec *lr;
2901 Scheme_Object **sa;
2902 int i, c;
2903
2904 lr = MALLOC_ONE_TAGGED(Scheme_Letrec);
2905 lr->so.type = scheme_letrec_type;
2906
2907 c = read_compact_number(port);
2908 if (c < 0) scheme_ill_formed_code(port);
2909
2910 lr->count = c;
2911 if (c < 4096)
2912 sa = MALLOC_N(Scheme_Object*, c);
2913 else {
2914 sa = scheme_malloc_fail_ok(scheme_malloc, scheme_check_overflow(c, sizeof(Scheme_Object *), 0));
2915 if (!sa) scheme_signal_error("out of memory allocating letrec bytecode");
2916 }
2917 lr->procs = sa;
2918
2919 for (i = 0; i < c; i++) {
2920 v = read_compact(port, 1);
2921 sa[i] = v;
2922 }
2923
2924 v = read_compact(port, 1);
2925 lr->body = v;
2926
2927 return (Scheme_Object *)lr;
2928 }
2929 break;
2930 case CPT_LET_ONE:
2931 case CPT_LET_ONE_TYPED:
2932 case CPT_LET_ONE_UNUSED:
2933 {
2934 Scheme_Let_One *lo;
2935 int et;
2936
2937 lo = (Scheme_Let_One *)scheme_malloc_tagged(sizeof(Scheme_Let_One));
2938 lo->iso.so.type = scheme_let_one_type;
2939
2940 v = read_compact(port, 1);
2941 lo->value = v;
2942 v = read_compact(port, 1);
2943 lo->body = v;
2944 et = scheme_get_eval_type(lo->value);
2945 if (ch == CPT_LET_ONE_TYPED) {
2946 int ty;
2947 ty = read_compact_number(port);
2948 et |= (ty << LET_ONE_TYPE_SHIFT);
2949 } else if (ch == CPT_LET_ONE_UNUSED)
2950 et |= LET_ONE_UNUSED;
2951 SCHEME_LET_EVAL_TYPE(lo) = et;
2952
2953 return (Scheme_Object *)lo;
2954 }
2955 break;
2956 case CPT_BRANCH:
2957 {
2958 Scheme_Object *test, *tbranch, *fbranch;
2959 test = read_compact(port, 1);
2960 tbranch = read_compact(port, 1);
2961 fbranch = read_compact(port, 1);
2962 return scheme_make_branch(test, tbranch, fbranch);
2963 }
2964 break;
2965 case CPT_WCM:
2966 {
2967 Scheme_With_Continuation_Mark *wcm;
2968
2969 wcm = MALLOC_ONE_TAGGED(Scheme_With_Continuation_Mark);
2970 wcm->so.type = scheme_with_cont_mark_type;
2971
2972 v = read_compact(port, 1);
2973 wcm->key = v;
2974 v = read_compact(port, 1);
2975 wcm->val = v;
2976 v = read_compact(port, 1);
2977 wcm->body = v;
2978
2979 return (Scheme_Object *)wcm;
2980 }
2981 break;
2982 case CPT_DEFINE_VALUES:
2983 {
2984 v = read_compact(port, 1);
2985 if (!SCHEME_VECTORP(v)) scheme_ill_formed_code(port);
2986 {
2987 int i, c = SCHEME_VEC_SIZE(v);
2988 if (c < 1) scheme_ill_formed_code(port);
2989 for (i = 1; i < c; i++) {
2990 if (!SAME_TYPE(SCHEME_TYPE(SCHEME_VEC_ELS(v)[i]), scheme_toplevel_type)
2991 && !SAME_TYPE(SCHEME_TYPE(SCHEME_VEC_ELS(v)[i]), scheme_static_toplevel_type))
2992 scheme_ill_formed_code(port);
2993 }
2994 }
2995 v->type = scheme_define_values_type;
2996 return v;
2997 }
2998 break;
2999 case CPT_SET_BANG:
3000 {
3001 Scheme_Set_Bang *sb;
3002
3003 sb = MALLOC_ONE_TAGGED(Scheme_Set_Bang);
3004 sb->so.type = scheme_set_bang_type;
3005
3006 if (read_compact_number(port))
3007 sb->set_undef = 1;
3008
3009 v = read_compact(port, 1);
3010 sb->var = v;
3011 if (!SAME_TYPE(SCHEME_TYPE(v), scheme_toplevel_type)
3012 && !SAME_TYPE(SCHEME_TYPE(v), scheme_static_toplevel_type))
3013 scheme_ill_formed_code(port);
3014 v = read_compact(port, 1);
3015 sb->val = v;
3016
3017 return (Scheme_Object *)sb;
3018 }
3019 break;
3020 case CPT_OTHER_FORM:
3021 {
3022 switch (read_compact_number(port)) {
3023 case scheme_static_toplevel_type:
3024 {
3025 Scheme_Object *tl = scheme_false;
3026 Scheme_Prefix *pf;
3027 intptr_t flags, pos, i;
3028
3029 flags = read_compact_number(port);
3030 pos = read_compact_number(port);
3031
3032 /* Avoid recur on very common case of a reference to the prefix: */
3033 ch = CP_GETC(port);
3034 if (ch == CPT_SYMREF) {
3035 l = read_compact_number(port);
3036 RANGE_POS_CHECK(l, < port->symtab_size);
3037 pf = (Scheme_Prefix *)port->symtab[l];
3038 } else {
3039 CP_UNGETC(port);
3040 pf = (Scheme_Prefix *)read_compact(port, 0);
3041 }
3042
3043 if (!SAME_TYPE(SCHEME_TYPE(pf), scheme_prefix_type) || (pos < 0) || (pos >= pf->num_slots))
3044 scheme_ill_formed_code(port);
3045
3046 flags &= SCHEME_TOPLEVEL_FLAGS_MASK;
3047 i = ((pos << SCHEME_LOG_TOPLEVEL_FLAG_MASK) | flags);
3048 if ((i < 0) || (i >= (pf->num_slots * (SCHEME_TOPLEVEL_FLAGS_MASK + 1))))
3049 scheme_ill_formed_code(port);
3050
3051 tl = ((Scheme_Object **)pf->a[pf->num_slots-1])[i];
3052 if (!tl) {
3053 tl = (Scheme_Object *)MALLOC_ONE_TAGGED(Scheme_Toplevel);
3054 tl->type = scheme_static_toplevel_type;
3055 SCHEME_STATIC_TOPLEVEL_PREFIX(tl) = pf;
3056 SCHEME_TOPLEVEL_POS(tl) = pos;
3057 SCHEME_TOPLEVEL_FLAGS(tl) |= flags;
3058 ((Scheme_Object **)pf->a[pf->num_slots-1])[i] = tl;
3059 }
3060
3061 return tl;
3062 }
3063 break;
3064 case scheme_prefix_type:
3065 {
3066 intptr_t prefix_size;
3067 Scheme_Object **a;
3068
3069 prefix_size = read_compact_number(port);
3070 if (prefix_size <= 0) scheme_ill_formed_code(port);
3071 if (prefix_size < 4096)
3072 v = (Scheme_Object *)scheme_allocate_prefix(prefix_size);
3073 else
3074 v = scheme_malloc_fail_ok((GC_Alloc_Proc)scheme_allocate_prefix, prefix_size);
3075
3076 /* Last prefix slot is a cache of Scheme_Toplevel values */
3077 a = MALLOC_N(Scheme_Object *, prefix_size * (SCHEME_TOPLEVEL_FLAGS_MASK + 1));
3078 ((Scheme_Prefix *)v)->a[prefix_size-1] = (Scheme_Object *)a;
3079
3080 return v;
3081 }
3082 case scheme_boxenv_type:
3083 {
3084 Scheme_Object *data;
3085
3086 data = scheme_alloc_object();
3087 data->type = scheme_boxenv_type;
3088
3089 v = read_compact(port, 1);
3090 SCHEME_PTR1_VAL(data) = v;
3091 v = read_compact(port, 1);
3092 SCHEME_PTR2_VAL(data) = v;
3093
3094 return data;
3095 }
3096 break;
3097 case scheme_with_immed_mark_type:
3098 {
3099 Scheme_With_Continuation_Mark *wcm;
3100
3101 wcm = MALLOC_ONE_TAGGED(Scheme_With_Continuation_Mark);
3102 wcm->so.type = scheme_with_immed_mark_type;
3103
3104 v = read_compact(port, 1);
3105 wcm->key = v;
3106 v = read_compact(port, 1);
3107 wcm->val = v;
3108 v = read_compact(port, 1);
3109 wcm->body = v;
3110
3111 return (Scheme_Object *)wcm;
3112 }
3113 case scheme_inline_variant_type:
3114 {
3115 Scheme_Object *data;
3116
3117 data = scheme_make_vector(3, scheme_false);
3118 data->type = scheme_inline_variant_type;
3119
3120 v = read_compact(port, 1);
3121 SCHEME_VEC_ELS(data)[0] = v;
3122 v = read_compact(port, 1);
3123 SCHEME_VEC_ELS(data)[1] = v;
3124 /* third slot is filled when linklet->accessible table is made */
3125
3126 return data;
3127 }
3128 case scheme_case_lambda_sequence_type:
3129 {
3130 int count, i, all_closed = 1;
3131 Scheme_Case_Lambda *cl;
3132
3133 count = read_compact_number(port);
3134 if (count < 0) scheme_ill_formed_code(port);
3135
3136 if (count < 4096)
3137 cl = (Scheme_Case_Lambda *)scheme_malloc_tagged(sizeof(Scheme_Case_Lambda)
3138 + (count - mzFLEX_DELTA) * sizeof(Scheme_Object *));
3139 else {
3140 intptr_t sz;
3141 sz = scheme_check_overflow((count - mzFLEX_DELTA), sizeof(Scheme_Object *), sizeof(Scheme_Case_Lambda));
3142 cl = (Scheme_Case_Lambda *)scheme_malloc_fail_ok(scheme_malloc_tagged, sz);
3143 if (!cl) scheme_signal_error("out of memory allocating procedure bytecode");
3144 }
3145
3146 cl->so.type = scheme_case_lambda_sequence_type;
3147 cl->count = count;
3148
3149 v = read_compact(port, 1);
3150 if (SCHEME_NULLP(v))
3151 cl->name = NULL;
3152 else
3153 cl->name = v;
3154
3155 for (i = 0; i < count; i++) {
3156 v = read_compact(port, 1);
3157 cl->array[i] = v;
3158 if (!SCHEME_PROCP(v)) {
3159 if (!SAME_TYPE(SCHEME_TYPE(v), scheme_lambda_type))
3160 scheme_ill_formed_code(port);
3161 all_closed = 0;
3162 } else if (!SAME_TYPE(SCHEME_TYPE(v), scheme_closure_type))
3163 scheme_ill_formed_code(port);
3164 }
3165
3166 if (all_closed) {
3167 /* Empty closure: produce procedure value directly.
3168 (We assume that this was generated by a direct write of
3169 a case-lambda data record in print.c, and that it's not
3170 in a CASE_LAMBDA_EXPD syntax record.) */
3171 return scheme_case_lambda_execute((Scheme_Object *)cl);
3172 }
3173
3174 return (Scheme_Object *)cl;
3175 }
3176 break;
3177 case scheme_lambda_type:
3178 {
3179 Scheme_Object *name, *ds, *closure_map, *tl_map;
3180 int flags, closure_size, num_params, max_let_depth;
3181
3182 flags = read_compact_number(port);
3183 if (flags & LAMBDA_HAS_TYPED_ARGS)
3184 closure_size = read_compact_number(port);
3185 else
3186 closure_size = -1;
3187 num_params = read_compact_number(port);
3188 max_let_depth = read_compact_number(port);
3189
3190 name = read_compact(port, 1);
3191 ds = read_compact(port, 1);
3192 closure_map = read_compact(port, 1);
3193 tl_map = read_compact(port, 1);
3194
3195 v = scheme_read_lambda(flags, closure_size, num_params, max_let_depth,
3196 name, ds, closure_map, tl_map);
3197 if (!v) scheme_ill_formed_code(port);
3198
3199 return v;
3200 }
3201 default:
3202 scheme_ill_formed_code(port);
3203 return NULL;
3204 break;
3205 }
3206 }
3207 break;
3208 case CPT_VARREF:
3209 {
3210 Scheme_Object *data;
3211 int flags;
3212
3213 data = scheme_alloc_object();
3214 data->type = scheme_varref_form_type;
3215
3216 flags = read_compact_number(port);
3217 SCHEME_VARREF_FLAGS(data) |= (flags & VARREF_FLAGS_MASK);
3218
3219 v = read_compact(port, 1);
3220 SCHEME_PTR1_VAL(data) = v;
3221 if (!SCHEME_SYMBOLP(v)
3222 && !SCHEME_FALSEP(v)
3223 && !SAME_OBJ(v, scheme_true)
3224 && !SAME_TYPE(SCHEME_TYPE(v), scheme_toplevel_type))
3225 scheme_ill_formed_code(port);
3226
3227 v = read_compact(port, 1);
3228 SCHEME_PTR2_VAL(data) = v;
3229 if (!SCHEME_FALSEP(v)
3230 && !SAME_TYPE(SCHEME_TYPE(v), scheme_toplevel_type))
3231 scheme_ill_formed_code(port);
3232
3233 return data;
3234 }
3235 break;
3236 case CPT_APPLY_VALUES:
3237 {
3238 Scheme_Object *data;
3239
3240 data = scheme_alloc_object();
3241 data->type = scheme_apply_values_type;
3242
3243 v = read_compact(port, 1);
3244 SCHEME_PTR1_VAL(data) = v;
3245 v = read_compact(port, 1);
3246 SCHEME_PTR2_VAL(data) = v;
3247
3248 return data;
3249 }
3250 break;
3251 case CPT_PATH:
3252 {
3253 l = read_compact_number(port);
3254 RANGE_CHECK_GETS(l);
3255 if (l) {
3256 s = read_compact_chars(port, buffer, BLK_BUF_SIZE, l);
3257 v = scheme_make_sized_path(s, l, l < BLK_BUF_SIZE);
3258 } else {
3259 Scheme_Object *elems;
3260 elems = read_compact(port, 0);
3261 if (SCHEME_PATHP(port->relto)) {
3262 /* Resolve relative path using the current load-relative directory: */
3263 v = port->relto;
3264 } else
3265 v = scheme_maybe_build_path(NULL, scheme_false);
3266 while (SCHEME_PAIRP(elems)) {
3267 v = scheme_maybe_build_path(v, SCHEME_CAR(elems));
3268 elems = SCHEME_CDR(elems);
3269 }
3270 }
3271 }
3272 break;
3273 case CPT_SRCLOC:
3274 {
3275 Scheme_Object *r;
3276 r = scheme_unsafe_make_location();
3277 /* No checking of field values, so a corrupt ".zo" can
3278 create bad srclocs (but won't crash while reading) */
3279 v = read_compact(port, 0);
3280 ((Scheme_Structure *)r)->slots[0] = v;
3281 v = read_compact(port, 0);
3282 ((Scheme_Structure *)r)->slots[1] = v;
3283 v = read_compact(port, 0);
3284 ((Scheme_Structure *)r)->slots[2] = v;
3285 v = read_compact(port, 0);
3286 ((Scheme_Structure *)r)->slots[3] = v;
3287 v = read_compact(port, 0);
3288 ((Scheme_Structure *)r)->slots[4] = v;
3289 return r;
3290 }
3291 break;
3292 case CPT_CLOSURE:
3293 {
3294 Scheme_Closure *cl;
3295 l = read_compact_number(port);
3296 RANGE_CHECK(l, < port->symtab_size);
3297 cl = scheme_malloc_empty_closure();
3298 port->symtab[l] = (Scheme_Object *)cl;
3299 v = read_compact(port, 0);
3300 if (!SAME_TYPE(SCHEME_TYPE(v), scheme_closure_type)
3301 || !((Scheme_Closure *)v)->code
3302 || ((Scheme_Closure *)v)->code->closure_size) {
3303 scheme_ill_formed_code(port);
3304 return NULL;
3305 }
3306 cl->code = ((Scheme_Closure *)v)->code;
3307 return (Scheme_Object *)cl;
3308 break;
3309 }
3310 case CPT_DELAY_REF:
3311 {
3312 l = read_compact_number(port);
3313 RANGE_POS_CHECK(l, < port->symtab_size);
3314 v = port->symtab[l];
3315 if (!v) {
3316 if (port->delay_info) {
3317 /* This is where we construct information for
3318 loading the lambda form on demand. */
3319 v = scheme_make_raw_pair(scheme_make_integer(l),
3320 (Scheme_Object *)port->delay_info);
3321 } else {
3322 intptr_t save_pos = port->pos;
3323 port->symtab[l] = SYMTAB_IN_PROGRESS; /* avoid cycles if marshaled form is broken: */
3324 port->pos = port->shared_offsets[l - 1];
3325 v = read_compact(port, 0);
3326 port->pos = save_pos;
3327 port->symtab[l] = v;
3328 }
3329 } else if (v == SYMTAB_IN_PROGRESS) {
3330 /* there is a cycle */
3331 scheme_ill_formed_code(port);
3332 }
3333 return v;
3334 break;
3335 }
3336 case CPT_PREFAB:
3337 {
3338 Scheme_Struct_Type *st;
3339 v = read_compact(port, 0);
3340 if (!SCHEME_VECTORP(v) || !SCHEME_VEC_SIZE(v))
3341 v = NULL;
3342 else {
3343 st = scheme_lookup_prefab_type(SCHEME_VEC_ELS(v)[0], SCHEME_VEC_SIZE(v) - 1);
3344 if (!st || (st->num_slots != (SCHEME_VEC_SIZE(v) - 1)))
3345 v = NULL;
3346 else {
3347 v = scheme_make_prefab_struct_instance(st, v);
3348 }
3349 }
3350 break;
3351 }
3352 case CPT_SMALL_LOCAL_START:
3353 case CPT_SMALL_LOCAL_UNBOX_START:
3354 {
3355 Scheme_Type type;
3356
3357 if (CPT_BETWEEN(ch, SMALL_LOCAL_UNBOX)) {
3358 type = scheme_local_unbox_type;
3359 ch -= CPT_SMALL_LOCAL_UNBOX_START;
3360 } else {
3361 type = scheme_local_type;
3362 ch -= CPT_SMALL_LOCAL_START;
3363 }
3364 return scheme_make_local(type, ch, 0);
3365 }
3366 break;
3367 case CPT_SMALL_SYMBOL_START:
3368 {
3369 l = ch - CPT_SMALL_SYMBOL_START;
3370 RANGE_CHECK_GETS(l);
3371 s = read_compact_chars(port, buffer, BLK_BUF_SIZE, l);
3372 if (!valid_utf8(s, l))
3373 scheme_ill_formed_code(port);
3374 v = scheme_intern_exact_symbol(s, l);
3375 }
3376 break;
3377 case CPT_SMALL_NUMBER_START:
3378 {
3379 l = ch - CPT_SMALL_NUMBER_START;
3380 return scheme_make_integer(l);
3381 }
3382 break;
3383 case CPT_SMALL_SVECTOR_START:
3384 {
3385 l = ch - CPT_SMALL_SVECTOR_START;
3386 v = read_compact_svector(port, l);
3387 }
3388 break;
3389 case CPT_SMALL_PROPER_LIST_START:
3390 case CPT_SMALL_LIST_START:
3391 {
3392 int ppr = CPT_BETWEEN(ch, SMALL_PROPER_LIST);
3393 l = ch - (ppr ? CPT_SMALL_PROPER_LIST_START : CPT_SMALL_LIST_START);
3394 if (l == 1) {
3395 Scheme_Object *cdr;
3396 v = read_compact(port, 0);
3397 cdr = (ppr
3398 ? scheme_null
3399 : read_compact(port, 0));
3400 return scheme_make_pair(v, cdr);
3401 } else
3402 return read_compact_list(l, ppr, /* use_stack */ 0, port);
3403 }
3404 break;
3405 case CPT_SMALL_APPLICATION_START:
3406 {
3407 int c, i;
3408 Scheme_App_Rec *a;
3409
3410 c = (ch - CPT_SMALL_APPLICATION_START) + 1;
3411
3412 a = scheme_malloc_application(c);
3413 for (i = 0; i < c; i++) {
3414 v = read_compact(port, 1);
3415 a->args[i] = v;
3416 }
3417
3418 scheme_finish_application(a);
3419
3420 return (Scheme_Object *)a;
3421 }
3422 break;
3423 case CPT_SMALL_APPLICATION2:
3424 {
3425 short et;
3426 Scheme_App2_Rec *app;
3427
3428 app = MALLOC_ONE_TAGGED(Scheme_App2_Rec);
3429 app->iso.so.type = scheme_application2_type;
3430
3431 v = read_compact(port, 1);
3432 app->rator = v;
3433 v = read_compact(port, 1);
3434 app->rand = v;
3435
3436 et = scheme_get_eval_type(app->rand);
3437 et = et << 3;
3438 et += scheme_get_eval_type(app->rator);
3439 SCHEME_APPN_FLAGS(app) = et;
3440
3441 return (Scheme_Object *)app;
3442 }
3443 break;
3444 case CPT_SMALL_APPLICATION3:
3445 {
3446 short et;
3447 Scheme_App3_Rec *app;
3448
3449 app = MALLOC_ONE_TAGGED(Scheme_App3_Rec);
3450 app->iso.so.type = scheme_application3_type;
3451
3452 v = read_compact(port, 1);
3453 app->rator = v;
3454 v = read_compact(port, 1);
3455 app->rand1 = v;
3456 v = read_compact(port, 1);
3457 app->rand2 = v;
3458
3459 et = scheme_get_eval_type(app->rand2);
3460 et = et << 3;
3461 et += scheme_get_eval_type(app->rand1);
3462 et = et << 3;
3463 et += scheme_get_eval_type(app->rator);
3464 SCHEME_APPN_FLAGS(app) = et;
3465
3466 return (Scheme_Object *)app;
3467 }
3468 break;
3469 case CPT_SHARED:
3470 {
3471 Scheme_Object *ph;
3472
3473 if (!port->ut)
3474 make_ut(port);
3475
3476 ph = scheme_alloc_small_object();
3477 ph->type = scheme_placeholder_type;
3478 SCHEME_PTR_VAL(ph) = scheme_false;
3479
3480 l = read_compact_number(port);
3481 RANGE_POS_CHECK(l, < port->symtab_size);
3482
3483 port->symtab[l] = ph;
3484
3485 v = scheme_make_pair(scheme_make_pair(scheme_make_integer(l),
3486 ph),
3487 port->symtab_refs);
3488 port->symtab_refs = v;
3489
3490 v = read_compact(port, 0);
3491 SCHEME_PTR_VAL(ph) = v;
3492
3493 return ph;
3494 }
3495 break;
3496 default:
3497 v = NULL;
3498 break;
3499 }
3500
3501 /* Some cases where v != NULL return directly */
3502
3503 if (!v)
3504 scheme_ill_formed_code(port);
3505 }
3506
3507 return v;
3508 }
3509
read_compact_list(int c,int proper,int use_stack,CPort * port)3510 static Scheme_Object *read_compact_list(int c, int proper, int use_stack, CPort *port)
3511 {
3512 Scheme_Object *v, *first, *last, *pair;
3513
3514 v = read_compact(port, 0);
3515 last = scheme_make_pair(v, scheme_null);
3516
3517 first = last;
3518
3519 while (--c) {
3520 v = read_compact(port, 0);
3521
3522 pair = scheme_make_pair(v, scheme_null);
3523
3524 SCHEME_CDR(last) = pair;
3525 last = pair;
3526 }
3527
3528 if (!proper) {
3529 v = read_compact(port, 0);
3530 SCHEME_CDR(last) = v;
3531 }
3532
3533 return first;
3534 }
3535
read_compact_quote(CPort * port,int embedded)3536 static Scheme_Object *read_compact_quote(CPort *port, int embedded)
3537 {
3538 Scheme_Hash_Table **q_ht, **old_ht;
3539 Scheme_Object *v;
3540
3541 /* Use a new hash table. A compiled quoted form may have graph
3542 structure, but only local graph structure is allowed. */
3543 q_ht = MALLOC_N(Scheme_Hash_Table *, 1);
3544 *q_ht = NULL;
3545
3546 old_ht = port->ht;
3547 port->ht = q_ht;
3548
3549 v = read_compact(port, 0);
3550
3551 port->ht = old_ht;
3552
3553 if (*q_ht)
3554 v = resolve_references(v, port->orig_port,
3555 scheme_make_hash_table(SCHEME_hash_ptr),
3556 scheme_make_hash_table(SCHEME_hash_ptr),
3557 port->symtab_entries,
3558 0, 0);
3559
3560 return v;
3561 }
3562
read_simple_number_from_port(Scheme_Object * port)3563 static intptr_t read_simple_number_from_port(Scheme_Object *port)
3564 {
3565 intptr_t a, b, c, d;
3566
3567 a = (unsigned char)scheme_get_byte(port);
3568 b = (unsigned char)scheme_get_byte(port);
3569 c = (unsigned char)scheme_get_byte(port);
3570 d = (unsigned char)scheme_get_byte(port);
3571
3572 return (a
3573 + (b << 8)
3574 + (c << 16)
3575 + (d << 24));
3576 }
3577
read_linklet_bundle_hash(Scheme_Object * port,int can_read_unsafe,Scheme_Object * delay_load_info)3578 static Scheme_Object *read_linklet_bundle_hash(Scheme_Object *port,
3579 int can_read_unsafe,
3580 Scheme_Object *delay_load_info)
3581 {
3582 Scheme_Object *result;
3583 intptr_t size, shared_size, got, offset;
3584 CPort *rp;
3585 intptr_t symtabsize;
3586 Scheme_Object **symtab;
3587 intptr_t *so;
3588 Scheme_Load_Delay *delay_info;
3589 Scheme_Hash_Table **local_ht;
3590 int all_short;
3591 int perma_cache = use_perma_cache;
3592 Scheme_Object *dir;
3593 Scheme_Config *config;
3594 Scheme_Performance_State perf_state;
3595
3596 scheme_performance_record_start(&perf_state);
3597
3598 /* Allow delays? */
3599 if (delay_load_info) {
3600 delay_info = MALLOC_ONE_RT(Scheme_Load_Delay);
3601 SET_REQUIRED_TAG(delay_info->type = scheme_rt_delay_load_info);
3602 delay_info->path = delay_load_info;
3603 } else
3604 delay_info = NULL;
3605
3606 symtabsize = read_simple_number_from_port(port);
3607
3608 /* Load table mapping symtab indices to stream positions: */
3609
3610 all_short = scheme_get_byte(port);
3611 if (symtabsize < 0)
3612 so = NULL;
3613 else
3614 so = (intptr_t *)scheme_malloc_fail_ok(scheme_malloc_atomic,
3615 scheme_check_overflow(symtabsize, sizeof(intptr_t), 0));
3616 if (!so)
3617 scheme_read_err(port,
3618 "read (compiled): could not allocate symbol table of size %" PRIdPTR,
3619 symtabsize);
3620 if ((got = scheme_get_bytes(port, (all_short ? 2 : 4) * (symtabsize - 1), (char *)so, 0))
3621 != ((all_short ? 2 : 4) * (symtabsize - 1)))
3622 scheme_read_err(port,
3623 "read (compiled): ill-formed code (bad table count: %" PRIdPTR " != %" PRIdPTR ")",
3624 got, (all_short ? 2 : 4) * (symtabsize - 1));
3625 {
3626 /* This loop runs top to bottom, since sizeof(long) may be larger
3627 than the decoded integers (but it's never shorter) */
3628 intptr_t j, v;
3629 unsigned char *so_c = (unsigned char *)so;
3630 for (j = symtabsize - 1; j--; ) {
3631 if (all_short) {
3632 v = so_c[j * 2]
3633 + (so_c[j * 2 + 1] << 8);
3634 } else {
3635 v = so_c[j * 4]
3636 + (so_c[j * 4 + 1] << 8)
3637 + (so_c[j * 4 + 2] << 16)
3638 + (so_c[j * 4 + 3] << 24);
3639 }
3640 so[j] = v;
3641 }
3642 }
3643
3644 /* Continue reading content */
3645
3646 shared_size = read_simple_number_from_port(port);
3647 size = read_simple_number_from_port(port);
3648
3649 if (shared_size >= size) {
3650 scheme_read_err(port,
3651 "read (compiled): ill-formed code (shared size %ld >= total size %ld)",
3652 shared_size, size);
3653 }
3654
3655 rp = MALLOC_ONE_RT(CPort);
3656 SET_REQUIRED_TAG(rp->type = scheme_rt_compact_port);
3657 {
3658 unsigned char *st;
3659 st = (unsigned char *)scheme_malloc_fail_ok(scheme_malloc_atomic, size + 1);
3660 rp->start = st;
3661 }
3662 rp->pos = 0;
3663 {
3664 intptr_t base;
3665 scheme_tell_all(port, NULL, NULL, &base);
3666 rp->base = base;
3667 }
3668 offset = SCHEME_INT_VAL(scheme_file_position(1, &port));
3669 rp->orig_port = port;
3670 rp->size = size;
3671 if ((got = scheme_get_bytes(port, size, (char *)rp->start, 0)) != size)
3672 scheme_read_err(port,
3673 "read (compiled): ill-formed code (bad count: %ld != %ld"
3674 ", started at %ld)",
3675 got, size, rp->base);
3676
3677 local_ht = MALLOC_N(Scheme_Hash_Table *, 1);
3678
3679 symtab = MALLOC_N(Scheme_Object *, symtabsize);
3680 rp->symtab_size = symtabsize;
3681 rp->ht = local_ht;
3682 rp->symtab = symtab;
3683 rp->unsafe_ok = can_read_unsafe;
3684
3685 {
3686 Scheme_Hash_Table *se_ht;
3687 se_ht = scheme_make_hash_table(SCHEME_hash_ptr);
3688 rp->symtab_entries = se_ht;
3689 if (delay_info)
3690 delay_info->symtab_entries = se_ht;
3691 }
3692
3693 config = scheme_current_config();
3694
3695 dir = scheme_get_param(config, MZCONFIG_LOAD_DIRECTORY);
3696 if (SCHEME_TRUEP(dir))
3697 dir = scheme_path_to_directory_path(dir);
3698 rp->relto = dir;
3699
3700 rp->shared_offsets = so;
3701 rp->delay_info = delay_info;
3702
3703 rp->symtab_refs = scheme_null;
3704
3705 if (!delay_info) {
3706 /* Read shared parts: */
3707 intptr_t j, len;
3708 Scheme_Object *v;
3709 len = symtabsize;
3710 for (j = 1; j < len; j++) {
3711 if (!symtab[j]) {
3712 v = read_compact(rp, 0);
3713 v = resolve_symtab_refs(v, rp);
3714 symtab[j] = v;
3715 } else {
3716 if (j+1 < len)
3717 rp->pos = so[j];
3718 else
3719 rp->pos = shared_size;
3720 }
3721 }
3722 } else {
3723 scheme_reserve_file_descriptor();
3724 rp->pos = shared_size; /* skip shared part */
3725 delay_info->file_offset = offset;
3726 delay_info->size = shared_size;
3727 delay_info->symtab_size = rp->symtab_size;
3728 delay_info->symtab = rp->symtab;
3729 delay_info->shared_offsets = rp->shared_offsets;
3730 delay_info->relto = rp->relto;
3731 delay_info->unsafe_ok = rp->unsafe_ok;
3732 delay_info->bytecode_hash = rp->bytecode_hash;
3733
3734 if (SAME_OBJ(delay_info->path, scheme_true))
3735 perma_cache = 1;
3736
3737 if (perma_cache) {
3738 unsigned char *cache;
3739 cache = (unsigned char *)scheme_malloc_atomic(shared_size);
3740 memcpy(cache, rp->start, shared_size);
3741 delay_info->cached = cache;
3742 delay_info->cached_port = port;
3743 delay_info->perma_cache = 1;
3744 }
3745 }
3746
3747 /* Read main body: */
3748 result = read_compact(rp, 1);
3749
3750 if (delay_info) {
3751 if (delay_info->ut)
3752 delay_info->ut->rp = NULL; /* clean up */
3753 }
3754
3755 if (*local_ht)
3756 scheme_read_err(port, "read (compiled): unexpected graph structure");
3757
3758 if (!SCHEME_HASHTRP(result))
3759 scheme_read_err(port, "read (compiled): bundle content is not an immutable hash");
3760
3761 {
3762 mzlonglong i;
3763 Scheme_Hash_Tree *t = (Scheme_Hash_Tree *)result;
3764 Scheme_Object *key, *val;
3765
3766 if (!scheme_starting_up) {
3767 i = scheme_hash_tree_next(t, -1);
3768 while (i != -1) {
3769 scheme_hash_tree_index(t, i, &key, &val);
3770 if (validate_loaded_linklet
3771 && SAME_TYPE(SCHEME_TYPE(val), scheme_linklet_type)
3772 && !((Scheme_Linklet *)val)->reject_eval)
3773 scheme_validate_linklet(rp, (Scheme_Linklet *)val);
3774 i = scheme_hash_tree_next(t, i);
3775 }
3776 }
3777
3778 /* If no exception, the resulting code is ok. */
3779 }
3780
3781 scheme_performance_record_end("read", &perf_state);
3782 return result;
3783 }
3784
scheme_read_linklet_bundle_hash(Scheme_Object * port)3785 Scheme_Object *scheme_read_linklet_bundle_hash(Scheme_Object *port)
3786 {
3787 Scheme_Config *config;
3788 int can_read_unsafe;
3789 Scheme_Object *delay_load_info, *v, *v2;
3790
3791 config = scheme_current_config();
3792
3793 v = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR);
3794 v2 = scheme_get_initial_inspector();
3795 can_read_unsafe = SAME_OBJ(v, v2);
3796
3797 v = scheme_get_param(config, MZCONFIG_DELAY_LOAD_INFO);
3798 if (SCHEME_TRUEP(v))
3799 delay_load_info = v;
3800 else
3801 delay_load_info = NULL;
3802
3803 return read_linklet_bundle_hash(port, can_read_unsafe, delay_load_info);
3804 }
3805
3806 THREAD_LOCAL_DECL(static Scheme_Load_Delay *clear_bytes_chain);
3807
scheme_clear_delayed_load_cache()3808 void scheme_clear_delayed_load_cache()
3809 {
3810 Scheme_Load_Delay *next;
3811
3812 while (clear_bytes_chain) {
3813 next = clear_bytes_chain->clear_bytes_next;
3814 clear_bytes_chain->cached = NULL;
3815 clear_bytes_chain->cached_port = NULL;
3816 clear_bytes_chain->clear_bytes_next = NULL;
3817 clear_bytes_chain->clear_bytes_prev = NULL;
3818 clear_bytes_chain = next;
3819 }
3820 }
3821
scheme_load_delayed_code(int _which,Scheme_Load_Delay * _delay_info)3822 Scheme_Object *scheme_load_delayed_code(int _which, Scheme_Load_Delay *_delay_info)
3823 {
3824 Scheme_Load_Delay * volatile delay_info = _delay_info;
3825 CPort *rp;
3826 CPort * volatile old_rp;
3827 volatile int which = _which;
3828 intptr_t size, got;
3829 unsigned char *st;
3830 Scheme_Object * volatile port;
3831 Scheme_Object * volatile v;
3832 Scheme_Object * volatile v_exn;
3833 Scheme_Hash_Table ** volatile ht;
3834 mz_jmp_buf newbuf, * volatile savebuf;
3835 Scheme_Performance_State perf_state;
3836
3837 scheme_performance_record_start(&perf_state);
3838
3839 /* Remove from cache-clearing chain: */
3840 if (!delay_info->perma_cache) {
3841 if (delay_info->clear_bytes_prev)
3842 delay_info->clear_bytes_prev->clear_bytes_next = delay_info->clear_bytes_next;
3843 else if (clear_bytes_chain == delay_info)
3844 clear_bytes_chain = delay_info->clear_bytes_next;
3845 if (delay_info->clear_bytes_next)
3846 delay_info->clear_bytes_next->clear_bytes_prev = delay_info->clear_bytes_prev;
3847
3848 delay_info->clear_bytes_prev = NULL;
3849 delay_info->clear_bytes_next = NULL;
3850 }
3851
3852 size = delay_info->size;
3853
3854 /* Load in file bytes: */
3855 if (!delay_info->cached) {
3856 Scheme_Object *a[1];
3857
3858 scheme_start_atomic();
3859 scheme_release_file_descriptor();
3860
3861 a[0] = delay_info->path;
3862 port = scheme_do_open_input_file("on-demand-loader", 0, 1, a, 1, 0);
3863
3864 savebuf = scheme_current_thread->error_buf;
3865 scheme_current_thread->error_buf = &newbuf;
3866 if (scheme_setjmp(newbuf)) {
3867 scheme_end_atomic_no_swap();
3868 scheme_close_input_port(port);
3869 scheme_current_thread->error_buf = savebuf;
3870 scheme_longjmp(*savebuf, 1);
3871 return NULL;
3872 } else {
3873 st = (unsigned char *)scheme_malloc_atomic(size + 1);
3874
3875 scheme_set_file_position(port, delay_info->file_offset);
3876
3877 if ((got = scheme_get_bytes(port, size, (char *)st, 0)) != size)
3878 scheme_read_err(port,
3879 "on-demand load: ill-formed code (bad count: %ld != %ld"
3880 ", started at %ld)",
3881 got, size, 0);
3882 }
3883 scheme_current_thread->error_buf = savebuf;
3884
3885 scheme_close_input_port(port);
3886 scheme_reserve_file_descriptor();
3887
3888 scheme_end_atomic_no_swap();
3889
3890 delay_info->cached = st;
3891 delay_info->cached_port = port;
3892 } else {
3893 port = delay_info->cached_port;
3894 }
3895
3896 /* Allow only one thread at a time. This is a little questionable,
3897 because unmarshalling could take arbitrarily long, and an
3898 untrusted program might construct an adversarial bytecode. That
3899 would be relatively difficult, though. In practice, unmarshalling
3900 will be fast. */
3901 scheme_start_atomic();
3902
3903 old_rp = delay_info->current_rp;
3904
3905 /* Create a port for reading: */
3906 rp = MALLOC_ONE_RT(CPort);
3907 SET_REQUIRED_TAG(rp->type = scheme_rt_compact_port);
3908 rp->start = delay_info->cached;
3909 rp->pos = 0;
3910 rp->base = 0;
3911 rp->orig_port = port;
3912 rp->size = size;
3913 rp->ut = delay_info->ut;
3914 rp->unsafe_ok = delay_info->unsafe_ok;
3915 rp->bytecode_hash = delay_info->bytecode_hash;
3916 rp->symtab_entries = delay_info->symtab_entries;
3917 if (delay_info->ut)
3918 delay_info->ut->rp = rp;
3919
3920 ht = MALLOC_N(Scheme_Hash_Table *, 1);
3921
3922 rp->symtab_size = delay_info->symtab_size;
3923 rp->ht = ht;
3924 rp->symtab = delay_info->symtab;
3925 rp->relto = delay_info->relto;
3926 rp->shared_offsets = delay_info->shared_offsets;
3927 rp->delay_info = delay_info;
3928 rp->symtab_refs = scheme_null;
3929
3930 rp->pos = delay_info->shared_offsets[which - 1];
3931
3932 /* Perform the read, catching escapes so we can clean up: */
3933 savebuf = scheme_current_thread->error_buf;
3934 scheme_current_thread->error_buf = &newbuf;
3935 scheme_current_thread->reading_delayed = scheme_true;
3936 if (scheme_setjmp(newbuf)) {
3937 v = NULL;
3938 v_exn = scheme_current_thread->reading_delayed;
3939 } else {
3940 v = read_compact(rp, 0);
3941 v_exn = NULL;
3942 if (*ht) {
3943 scheme_read_err(rp->orig_port, "read (compiled): unexpected graph structure");
3944 }
3945 }
3946 scheme_current_thread->error_buf = savebuf;
3947 scheme_current_thread->reading_delayed = NULL;
3948
3949 /* Clean up: */
3950 v = resolve_symtab_refs(v, rp);
3951
3952 delay_info->current_rp = old_rp;
3953 if (delay_info->ut)
3954 delay_info->ut->rp = old_rp;
3955
3956 if (!old_rp && !delay_info->perma_cache) {
3957 /* No one using the cache, to register it to be cleaned up */
3958 delay_info->clear_bytes_next = clear_bytes_chain;
3959 if (clear_bytes_chain)
3960 clear_bytes_chain->clear_bytes_prev = delay_info;
3961 clear_bytes_chain = delay_info;
3962 }
3963
3964 scheme_end_atomic_no_swap();
3965
3966 scheme_performance_record_end("demand-read", &perf_state);
3967
3968 if (v) {
3969 /* Although `which` is a symbol-table index for `v`,
3970 we don't actually record v, because the delayed
3971 reference is now complete (and we'd like to be
3972 able to GC it if it's otherwise unused). */
3973 return v;
3974 } else {
3975 if (v_exn && !scheme_current_thread->cjs.is_kill)
3976 scheme_raise(v_exn);
3977 scheme_longjmp(*scheme_current_thread->error_buf, 1);
3978 return NULL;
3979 }
3980 }
3981
scheme_unmarshal_wrap_get(Scheme_Unmarshal_Tables * ut,Scheme_Object * wraps_key,int * _decoded)3982 Scheme_Object *scheme_unmarshal_wrap_get(Scheme_Unmarshal_Tables *ut,
3983 Scheme_Object *wraps_key,
3984 int *_decoded)
3985 {
3986 intptr_t l;
3987 l = SCHEME_INT_VAL(wraps_key);
3988
3989 if ((l < 0) || ((uintptr_t)l >= ut->rp->symtab_size))
3990 scheme_ill_formed_code(ut->rp);
3991 if (SAME_OBJ(ut->rp->symtab[l], SYMTAB_IN_PROGRESS))
3992 scheme_ill_formed_code(ut->rp);
3993
3994 if (!ut->rp->symtab[l]) {
3995 Scheme_Object *v;
3996 intptr_t save_pos;
3997
3998 if (!ut->rp->delay_info)
3999 scheme_ill_formed_code(ut->rp);
4000
4001 save_pos = ut->rp->pos;
4002 ut->rp->pos = ut->rp->shared_offsets[l - 1];
4003 v = read_compact(ut->rp, 0);
4004 ut->rp->pos = save_pos;
4005 ut->rp->symtab[l] = v;
4006 }
4007
4008 *_decoded = ut->decoded[l];
4009 return ut->rp->symtab[l];
4010 }
4011
scheme_unmarshal_wrap_set(Scheme_Unmarshal_Tables * ut,Scheme_Object * wraps_key,Scheme_Object * v)4012 void scheme_unmarshal_wrap_set(Scheme_Unmarshal_Tables *ut,
4013 Scheme_Object *wraps_key,
4014 Scheme_Object *v)
4015 {
4016 intptr_t l;
4017 l = SCHEME_INT_VAL(wraps_key);
4018
4019 ut->rp->symtab[l] = v;
4020 ut->decoded[l] = 1;
4021 }
4022
4023 /*========================================================================*/
4024 /* precise GC traversers g*/
4025 /*========================================================================*/
4026
4027 #ifdef MZ_PRECISE_GC
4028
4029 START_XFORM_SKIP;
4030
4031 #include "mzmark_read.inc"
4032
register_traversers(void)4033 static void register_traversers(void)
4034 {
4035 GC_REG_TRAV(scheme_indent_type, mark_indent);
4036 GC_REG_TRAV(scheme_rt_compact_port, mark_cport);
4037 GC_REG_TRAV(scheme_rt_read_params, mark_read_params);
4038 GC_REG_TRAV(scheme_rt_delay_load_info, mark_delay_load);
4039 GC_REG_TRAV(scheme_rt_unmarshal_info, mark_unmarshal_tables);
4040 }
4041
4042 END_XFORM_SKIP;
4043
4044 #endif
4045