1 /* This file implements front-end compilation.
2
3 The intermediate format generated from here accumulates references
4 to non-local variables in a prefix, and it indicates whether each
5 local variable is mutatble.
6
7 See "eval.c" for an overview of compilation passes.
8
9 The main compile loop is compile_expr(). */
10
11 #include "schpriv.h"
12 #include "schmach.h"
13
14 /* globals */
15 READ_ONLY Scheme_Object scheme_undefined[1];
16
17 /* symbols */
18 ROSYM static Scheme_Object *lambda_symbol;
19 ROSYM static Scheme_Object *case_lambda_symbol;
20 ROSYM static Scheme_Object *ref_symbol;
21 ROSYM static Scheme_Object *quote_symbol;
22 ROSYM static Scheme_Object *if_symbol;
23 ROSYM static Scheme_Object *set_symbol;
24 ROSYM static Scheme_Object *let_values_symbol;
25 ROSYM static Scheme_Object *letrec_values_symbol;
26 ROSYM static Scheme_Object *begin_symbol;
27 ROSYM static Scheme_Object *begin0_symbol;
28 ROSYM static Scheme_Object *with_cont_mark_symbol;
29 ROSYM static Scheme_Object *define_values_symbol;
30
31 ROSYM static Scheme_Object *compiler_inline_hint_symbol;
32 ROSYM static Scheme_Object *protected_symbol;
33 ROSYM static Scheme_Object *values_symbol;
34 ROSYM static Scheme_Object *call_with_values_symbol;
35 ROSYM static Scheme_Object *inferred_name_symbol;
36 ROSYM static Scheme_Object *source_name_symbol;
37
38 /* locals */
39 static Scheme_Object *lambda_compile(Scheme_Object *form, Scheme_Comp_Env *env);
40 static Scheme_Object *case_lambda_compile(Scheme_Object *form, Scheme_Comp_Env *env);
41 static Scheme_Object *ref_compile(Scheme_Object *form, Scheme_Comp_Env *env);
42 static Scheme_Object *quote_compile(Scheme_Object *form, Scheme_Comp_Env *env);
43 static Scheme_Object *if_compile(Scheme_Object *form, Scheme_Comp_Env *env);
44 static Scheme_Object *set_compile(Scheme_Object *form, Scheme_Comp_Env *env);
45 static Scheme_Object *letrec_values_compile (Scheme_Object *form, Scheme_Comp_Env *env);
46 static Scheme_Object *begin_compile (Scheme_Object *form, Scheme_Comp_Env *env);
47 static Scheme_Object *begin0_compile (Scheme_Object *form, Scheme_Comp_Env *env);
48 static Scheme_Object *with_cont_mark_compile(Scheme_Object *form, Scheme_Comp_Env *env);
49
50 static Scheme_Object *compile_expr(Scheme_Object *form, Scheme_Comp_Env *env, int app_position);
51 static Scheme_Object *compile_list(Scheme_Object *form,
52 Scheme_Comp_Env *first_env, Scheme_Comp_Env *env, Scheme_Comp_Env *last_env,
53 int start_app_position);
54 static Scheme_Object *compile_app(Scheme_Object *form, Scheme_Comp_Env *env);
55
56 static Scheme_Object *generate_defn_name(Scheme_Object *base_sym,
57 Scheme_Hash_Tree *used_names,
58 Scheme_Hash_Tree *also_used_names,
59 int search_start);
60
61 static Scheme_Object *extract_source_name(Scheme_Object *e, int no_default);
62
63 #ifdef MZ_PRECISE_GC
64 static void register_traversers(void);
65 #endif
66
67 #define cons(a,b) scheme_make_pair(a,b)
68 #define icons(a,b) scheme_make_pair(a,b)
69
70 /**********************************************************************/
71 /* initialization */
72 /**********************************************************************/
73
scheme_init_compile(Scheme_Startup_Env * env)74 void scheme_init_compile (Scheme_Startup_Env *env)
75 {
76 #ifdef MZ_PRECISE_GC
77 register_traversers();
78 #endif
79
80 REGISTER_SO(lambda_symbol);
81 REGISTER_SO(case_lambda_symbol);
82 REGISTER_SO(ref_symbol);
83 REGISTER_SO(quote_symbol);
84 REGISTER_SO(if_symbol);
85 REGISTER_SO(set_symbol);
86 REGISTER_SO(let_values_symbol);
87 REGISTER_SO(letrec_values_symbol);
88 REGISTER_SO(begin_symbol);
89 REGISTER_SO(begin0_symbol);
90 REGISTER_SO(with_cont_mark_symbol);
91 REGISTER_SO(define_values_symbol);
92
93 lambda_symbol = scheme_intern_symbol("lambda");
94 case_lambda_symbol = scheme_intern_symbol("case-lambda");
95 ref_symbol = scheme_intern_symbol("#%variable-reference");
96 quote_symbol = scheme_intern_symbol("quote");
97 if_symbol = scheme_intern_symbol("if");
98 set_symbol = scheme_intern_symbol("set!");
99 let_values_symbol = scheme_intern_symbol("let-values");
100 letrec_values_symbol = scheme_intern_symbol("letrec-values");
101 begin_symbol = scheme_intern_symbol("begin");
102 begin0_symbol = scheme_intern_symbol("begin0");
103 with_cont_mark_symbol = scheme_intern_symbol("with-continuation-mark");
104 define_values_symbol = scheme_intern_symbol("define-values");
105
106 REGISTER_SO(compiler_inline_hint_symbol);
107 REGISTER_SO(inferred_name_symbol);
108 REGISTER_SO(source_name_symbol);
109
110 scheme_undefined->type = scheme_undefined_type;
111
112 compiler_inline_hint_symbol = scheme_intern_symbol("compiler-hint:cross-module-inline");
113
114 inferred_name_symbol = scheme_intern_symbol("inferred-name");
115 source_name_symbol = scheme_intern_symbol("source-name");
116
117 REGISTER_SO(protected_symbol);
118 REGISTER_SO(values_symbol);
119 REGISTER_SO(call_with_values_symbol);
120
121 protected_symbol = scheme_intern_symbol("protected");
122 values_symbol = scheme_intern_symbol("values");
123 call_with_values_symbol = scheme_intern_symbol("call-with-values");
124
125 scheme_init_marshal(env);
126 }
127
scheme_init_compile_places()128 void scheme_init_compile_places()
129 {
130 }
131
132 /**********************************************************************/
133 /* utilities */
134 /**********************************************************************/
135
check_form(Scheme_Object * form,Scheme_Object * base_form)136 static int check_form(Scheme_Object *form, Scheme_Object *base_form)
137 {
138 int i;
139
140 for (i = 0; SCHEME_STX_PAIRP(form); i++) {
141 form = SCHEME_STX_CDR(form);
142 }
143
144 if (!SCHEME_STX_NULLP(form)) {
145 scheme_wrong_syntax(NULL, form, base_form, IMPROPER_LIST_FORM);
146 }
147
148 return i;
149 }
150
bad_form(Scheme_Object * form,int l)151 static void bad_form(Scheme_Object *form, int l)
152 {
153 scheme_wrong_syntax(NULL, NULL, form,
154 "bad syntax;\n has %d part%s after keyword",
155 l - 1, (l != 2) ? "s" : "");
156 }
157
check_name_property(Scheme_Object * code,Scheme_Comp_Env * env)158 static Scheme_Comp_Env *check_name_property(Scheme_Object *code, Scheme_Comp_Env *env)
159 {
160 Scheme_Object *name;
161
162 name = scheme_stx_property(code, inferred_name_symbol, NULL);
163 if (name && SCHEME_SYMBOLP(name))
164 return scheme_set_comp_env_name(env, name);
165 else
166 return env;
167 }
168
169 /**********************************************************************/
170 /* lambda utils */
171 /**********************************************************************/
172
lambda_check(Scheme_Object * form)173 static Scheme_Object *lambda_check(Scheme_Object *form)
174 {
175 if (SCHEME_STX_PAIRP(form)
176 && SCHEME_STX_PAIRP(SCHEME_STX_CDR(form))) {
177 Scheme_Object *rest;
178 rest = SCHEME_STX_CDR(form);
179 if (SCHEME_STX_PAIRP(SCHEME_STX_CDR(rest))) {
180 int len;
181 len = check_form(form, form);
182 if (len != 3)
183 bad_form(form, len);
184
185 return form;
186 }
187 }
188
189 scheme_wrong_syntax(NULL, NULL, form, NULL);
190 return NULL;
191 }
192
lambda_check_args(Scheme_Object * args,Scheme_Object * form,Scheme_Comp_Env * env)193 static void lambda_check_args(Scheme_Object *args, Scheme_Object *form, Scheme_Comp_Env *env)
194 {
195 Scheme_Object *v, *a;
196 DupCheckRecord r;
197
198 if (!SCHEME_STX_SYMBOLP(args)) {
199 for (v = args; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) {
200 a = SCHEME_STX_CAR(v);
201 scheme_check_identifier(NULL, a, NULL, form);
202 }
203
204 if (!SCHEME_STX_NULLP(v)) {
205 if (!SCHEME_STX_SYMBOLP(v)) {
206 scheme_check_identifier(NULL, v, NULL, form);
207 }
208 }
209
210 /* Check for duplicate names: */
211 scheme_begin_dup_symbol_check(&r);
212 for (v = args; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) {
213 Scheme_Object *name;
214
215 name = SCHEME_STX_CAR(v);
216 scheme_dup_symbol_check(&r, NULL, name, "argument", form);
217 }
218 if (!SCHEME_STX_NULLP(v)) {
219 scheme_dup_symbol_check(&r, NULL, v, "argument", form);
220 }
221 }
222 }
223
scheme_source_to_name(Scheme_Object * code)224 Scheme_Object *scheme_source_to_name(Scheme_Object *code)
225 /* Makes up a procedure name when there's not a good one in the source */
226 {
227 Scheme_Stx *cstx = (Scheme_Stx *)code;
228
229 if (!SCHEME_STXP(code))
230 return NULL;
231
232 if ((cstx->srcloc->col >= 0) || (cstx->srcloc->pos >= 0)) {
233 char buf[50], src[20];
234 Scheme_Object *name, *bstr;
235 int convert_backslash = 0;
236
237 if (cstx->srcloc->src) {
238 if (SCHEME_PATHP(cstx->srcloc->src)) {
239 bstr = cstx->srcloc->src;
240 /* for generating consistent names on machines with different platform
241 conventions, convert "\" to "/" */
242 convert_backslash = 1;
243 } else if (SCHEME_CHAR_STRINGP(cstx->srcloc->src))
244 bstr = scheme_char_string_to_byte_string(cstx->srcloc->src);
245 else
246 bstr = NULL;
247 } else
248 bstr = NULL;
249
250 if (bstr) {
251 if (SCHEME_BYTE_STRLEN_VAL(bstr) < 20)
252 memcpy(src, SCHEME_BYTE_STR_VAL(bstr), SCHEME_BYTE_STRLEN_VAL(bstr) + 1);
253 else {
254 memcpy(src, SCHEME_BYTE_STR_VAL(bstr) + SCHEME_BYTE_STRLEN_VAL(bstr) - 19, 20);
255 src[0] = '.';
256 src[1] = '.';
257 src[2] = '.';
258 }
259 if (convert_backslash) {
260 int i;
261 for (i = 0; src[i]; i++) {
262 if (src[i] == '\\')
263 src[i] = '/';
264 }
265 }
266 } else {
267 return NULL;
268 }
269
270 if (cstx->srcloc->line >= 0) {
271 sprintf(buf, "%s%s%" PRIdPTR ":%" PRIdPTR,
272 src, (src[0] ? ":" : ""), cstx->srcloc->line, cstx->srcloc->col - 1);
273 } else {
274 sprintf(buf, "%s%s%" PRIdPTR,
275 src, (src[0] ? "::" : ""), cstx->srcloc->pos);
276 }
277
278 name = scheme_intern_exact_symbol(buf, strlen(buf));
279 return name;
280 }
281
282 return NULL;
283 }
284
combine_name_with_srcloc(Scheme_Object * name,Scheme_Object * code,int src_based_name)285 Scheme_Object *combine_name_with_srcloc(Scheme_Object *name, Scheme_Object *code, int src_based_name)
286 {
287 Scheme_Stx *cstx = (Scheme_Stx *)code;
288
289 if (!SCHEME_STXP(code))
290 return name;
291
292 if (((cstx->srcloc->col >= 0) || (cstx->srcloc->pos >= 0))
293 && cstx->srcloc->src) {
294 Scheme_Object *vec;
295 vec = scheme_make_vector(7, NULL);
296 SCHEME_VEC_ELS(vec)[0] = name;
297 SCHEME_VEC_ELS(vec)[1] = cstx->srcloc->src;
298 if (cstx->srcloc->line >= 0) {
299 SCHEME_VEC_ELS(vec)[2] = scheme_make_integer(cstx->srcloc->line);
300 SCHEME_VEC_ELS(vec)[3] = scheme_make_integer(cstx->srcloc->col-1);
301 } else {
302 SCHEME_VEC_ELS(vec)[2] = scheme_false;
303 SCHEME_VEC_ELS(vec)[3] = scheme_false;
304 }
305 if (cstx->srcloc->pos >= 0)
306 SCHEME_VEC_ELS(vec)[4] = scheme_make_integer(cstx->srcloc->pos);
307 else
308 SCHEME_VEC_ELS(vec)[4] = scheme_false;
309 if (cstx->srcloc->span >= 0)
310 SCHEME_VEC_ELS(vec)[5] = scheme_make_integer(cstx->srcloc->span);
311 else
312 SCHEME_VEC_ELS(vec)[5] = scheme_false;
313 SCHEME_VEC_ELS(vec)[6] = (src_based_name ? scheme_true : scheme_false);
314
315 return vec;
316 }
317
318 return name;
319 }
320
scheme_build_closure_name(Scheme_Object * code,Scheme_Comp_Env * env)321 Scheme_Object *scheme_build_closure_name(Scheme_Object *code, Scheme_Comp_Env *env)
322 {
323 Scheme_Object *name;
324
325 name = scheme_stx_property(code, inferred_name_symbol, NULL);
326 if (name && SCHEME_SYMBOLP(name)) {
327 name = combine_name_with_srcloc(name, code, 0);
328 } else if (name && SCHEME_VOIDP(name)) {
329 name = scheme_source_to_name(code);
330 if (name)
331 name = combine_name_with_srcloc(name, code, 1);
332 } else {
333 name = env->value_name;
334 if (name)
335 name = SCHEME_STX_SYM(name);
336 if (!name || SCHEME_FALSEP(name)) {
337 name = scheme_source_to_name(code);
338 if (name)
339 name = combine_name_with_srcloc(name, code, 1);
340 } else {
341 name = combine_name_with_srcloc(name, code, 0);
342 }
343 }
344
345 #if RECORD_ALLOCATION_COUNTS
346 if (!name) {
347 /* Try harder to synthesize a name */
348 char *s;
349 int len;
350 s = scheme_write_to_string(scheme_syntax_to_datum(code),
351 NULL);
352 len = strlen(s);
353 if (len > 100) s[100] = 0;
354 name = scheme_make_symbol(s);
355 }
356 #endif
357
358 return name;
359 }
360
make_lambda(Scheme_Comp_Env * env,Scheme_Object * code)361 static Scheme_Object *make_lambda(Scheme_Comp_Env *env, Scheme_Object *code)
362 /* Compiles a `lambda' expression */
363 {
364 Scheme_Object *allparams, *params, *forms, *param, *name;
365 Scheme_Lambda *lam;
366 intptr_t num_params;
367 Scheme_IR_Local *var, **vars;
368 Scheme_IR_Lambda_Info *cl;
369 int i;
370
371 lam = MALLOC_ONE_TAGGED(Scheme_Lambda);
372
373 lam->iso.so.type = scheme_ir_lambda_type;
374
375 params = SCHEME_STX_CDR(code);
376 params = SCHEME_STX_CAR(params);
377 allparams = params;
378
379 num_params = 0;
380 for (; SCHEME_STX_PAIRP(params); params = SCHEME_STX_CDR(params)) {
381 num_params++;
382 }
383 SCHEME_LAMBDA_FLAGS(lam) = 0;
384 if (!SCHEME_STX_NULLP(params)) {
385 SCHEME_LAMBDA_FLAGS(lam) |= LAMBDA_HAS_REST;
386 num_params++;
387 }
388 lam->num_params = num_params;
389 if ((lam->num_params > 0) && scheme_has_method_property(code))
390 SCHEME_LAMBDA_FLAGS(lam) |= LAMBDA_IS_METHOD;
391
392 forms = SCHEME_STX_CDR(code);
393 forms = SCHEME_STX_CDR(forms);
394
395 env = check_name_property(code, env);
396 name = scheme_build_closure_name(code, env);
397 lam->name = name;
398
399 env = scheme_set_comp_env_name(env, NULL);
400
401 vars = MALLOC_N(Scheme_IR_Local*, num_params);
402
403 params = allparams;
404 for (i = 0; i < num_params; i++) {
405 if (!SCHEME_STX_PAIRP(params))
406 param = params;
407 else
408 param = SCHEME_STX_CAR(params);
409 var = scheme_make_ir_local(param);
410 vars[i] = var;
411 env = scheme_extend_comp_env(env, param, (Scheme_Object *)var, i > 0, 0);
412 if (SCHEME_STX_PAIRP(params))
413 params = SCHEME_STX_CDR (params);
414 }
415
416 if (SCHEME_STX_NULLP(forms))
417 scheme_wrong_syntax(NULL, NULL, code, "empty body not allowed");
418
419 {
420 Scheme_Object *body;
421 body = compile_expr(SCHEME_STX_CAR(forms), env, 0);
422 lam->body = body;
423 }
424
425 cl = MALLOC_ONE_RT(Scheme_IR_Lambda_Info);
426 SET_REQUIRED_TAG(cl->type = scheme_rt_ir_lambda_info);
427 cl->vars = vars;
428 lam->ir_info = cl;
429
430 return (Scheme_Object *)lam;
431 }
432
lambda_compile(Scheme_Object * form,Scheme_Comp_Env * env)433 static Scheme_Object *lambda_compile (Scheme_Object *form, Scheme_Comp_Env *env)
434 {
435 Scheme_Object *args;
436
437 form = lambda_check(form);
438
439 args = SCHEME_STX_CDR(form);
440 args = SCHEME_STX_CAR(args);
441 lambda_check_args(args, form, env);
442
443 return make_lambda(env, form);
444 }
445
scheme_clone_vector(Scheme_Object * lam,int skip,int set_type)446 Scheme_Object *scheme_clone_vector(Scheme_Object *lam, int skip, int set_type)
447 {
448 Scheme_Object *naya;
449 int i, size;
450
451 size = SCHEME_VEC_SIZE(lam);
452 naya = scheme_make_vector(size - skip, NULL);
453 for (i = skip; i < size; i++) {
454 SCHEME_VEC_ELS(naya)[i - skip] = SCHEME_VEC_ELS(lam)[i];
455 }
456
457 if (set_type)
458 naya->type = lam->type;
459
460 return naya;
461 }
462
463 /**********************************************************************/
464 /* quote */
465 /**********************************************************************/
466
quote_compile(Scheme_Object * form,Scheme_Comp_Env * env)467 static Scheme_Object *quote_compile (Scheme_Object *form, Scheme_Comp_Env *env)
468 {
469 Scheme_Object *v, *rest;
470
471 rest = SCHEME_STX_CDR(form);
472 if (!(SCHEME_STX_PAIRP(rest) && SCHEME_STX_NULLP(SCHEME_STX_CDR(rest))))
473 scheme_wrong_syntax(NULL, NULL, form, "wrong number of parts");
474
475 v = SCHEME_STX_CAR(rest);
476
477 return scheme_syntax_to_datum(v);
478 }
479
480 /**********************************************************************/
481 /* if */
482 /**********************************************************************/
483
check_if_len(Scheme_Object * form,int len)484 static void check_if_len(Scheme_Object *form, int len)
485 {
486 if (len != 4) {
487 if (len == 3) {
488 scheme_wrong_syntax(NULL, NULL, form,
489 "missing an \"else\" expression");
490 } else {
491 bad_form(form, len);
492 }
493 }
494 }
495
scheme_make_branch(Scheme_Object * test,Scheme_Object * thenp,Scheme_Object * elsep)496 Scheme_Object *scheme_make_branch(Scheme_Object *test, Scheme_Object *thenp,
497 Scheme_Object *elsep)
498 {
499 Scheme_Branch_Rec *b;
500
501 if (SCHEME_TYPE(test) > _scheme_ir_values_types_) {
502 if (SCHEME_FALSEP(test))
503 return elsep;
504 else
505 return thenp;
506 }
507
508 b = MALLOC_ONE_TAGGED(Scheme_Branch_Rec);
509 b->so.type = scheme_branch_type;
510
511 b->test = test;
512 b->tbranch = thenp;
513 b->fbranch = elsep;
514
515 return (Scheme_Object *)b;
516 }
517
if_compile(Scheme_Object * form,Scheme_Comp_Env * env)518 static Scheme_Object *if_compile (Scheme_Object *form, Scheme_Comp_Env *env)
519 {
520 int len, opt;
521 Scheme_Object *test, *thenp, *elsep, *rest;
522
523 len = check_form(form, form);
524 check_if_len(form, len);
525
526 env = check_name_property(form, env);
527
528 rest = SCHEME_STX_CDR(form);
529 test = SCHEME_STX_CAR(rest);
530 rest = SCHEME_STX_CDR(rest);
531 thenp = SCHEME_STX_CAR(rest);
532 if (len == 4) {
533 rest = SCHEME_STX_CDR(rest);
534 elsep = SCHEME_STX_CAR(rest);
535 } else
536 elsep = scheme_compiled_void();
537
538 test = compile_expr(test, scheme_set_comp_env_name(env, NULL), 0);
539
540 if (SCHEME_TYPE(test) > _scheme_ir_values_types_) {
541 opt = 1;
542
543 if (SCHEME_FALSEP(test)) {
544 /* compile other branch only to get syntax checking: */
545 compile_expr(thenp, scheme_set_comp_env_flags(env, COMP_ENV_DONT_COUNT_AS_USE), 0);
546
547 if (len == 4)
548 test = compile_expr(elsep, env, 0);
549 else
550 test = elsep;
551 } else {
552 if (len == 4) {
553 /* compile other branch only to get syntax checking: */
554 compile_expr(elsep, scheme_set_comp_env_flags(env, COMP_ENV_DONT_COUNT_AS_USE), 0);
555 }
556
557 test = compile_expr(thenp, env, 0);
558 }
559 } else {
560 opt = 0;
561 thenp = compile_expr(thenp, env, 0);
562 if (len == 4)
563 elsep = compile_expr(elsep, env, 0);
564 }
565
566 if (opt)
567 return test;
568 else
569 return scheme_make_branch(test, thenp, elsep);
570 }
571
572 /**********************************************************************/
573 /* with-continuation-mark */
574 /**********************************************************************/
575
with_cont_mark_compile(Scheme_Object * form,Scheme_Comp_Env * env)576 static Scheme_Object *with_cont_mark_compile(Scheme_Object *form, Scheme_Comp_Env *env)
577 {
578 Scheme_Object *key, *val, *expr;
579 Scheme_Comp_Env *k_env;
580 Scheme_With_Continuation_Mark *wcm;
581 int len;
582
583 len = check_form(form, form);
584
585 if (len != 4)
586 bad_form(form, len);
587
588 form = SCHEME_STX_CDR(form);
589 key = SCHEME_STX_CAR(form);
590 form = SCHEME_STX_CDR(form);
591 val = SCHEME_STX_CAR(form);
592 form = SCHEME_STX_CDR(form);
593 expr = SCHEME_STX_CAR(form);
594
595 k_env = scheme_set_comp_env_name(env, NULL);
596
597 key = compile_expr(key, k_env, 0);
598 val = compile_expr(val, k_env, 0);
599 expr = compile_expr(expr, env, 0);
600
601 wcm = MALLOC_ONE_TAGGED(Scheme_With_Continuation_Mark);
602 wcm->so.type = scheme_with_cont_mark_type;
603 wcm->key = key;
604 wcm->val = val;
605 wcm->body = expr;
606
607 return (Scheme_Object *)wcm;
608 }
609
610 /**********************************************************************/
611 /* set! */
612 /**********************************************************************/
613
set_compile(Scheme_Object * form,Scheme_Comp_Env * env)614 static Scheme_Object *set_compile (Scheme_Object *form, Scheme_Comp_Env *env)
615 {
616 Scheme_Set_Bang *sb;
617 Scheme_Object *var, *val, *name, *body, *rest;
618 int l, set_undef;
619
620 l = check_form(form, form);
621 if (l != 3)
622 bad_form(form, l);
623
624 rest = SCHEME_STX_CDR(form);
625 name = SCHEME_STX_CAR(rest);
626 rest = SCHEME_STX_CDR(rest);
627 body = SCHEME_STX_CAR(rest);
628
629 scheme_check_identifier("set!", name, NULL, form);
630
631 var = scheme_compile_lookup(name, env, SCHEME_SETTING);
632
633 if (SAME_TYPE(SCHEME_TYPE(var), scheme_ir_toplevel_type)) {
634 if (((Scheme_IR_Toplevel *)var)->instance_pos != -1)
635 scheme_wrong_syntax(NULL, form, name, "cannot mutate imported variable");
636 SCHEME_IR_TOPLEVEL_FLAGS(((Scheme_IR_Toplevel *)var)) |= SCHEME_IR_TOPLEVEL_MUTATED;
637 } else if (SAME_TYPE(SCHEME_TYPE(var), scheme_ir_local_type)) {
638 if (((Scheme_IR_Local *)var)->compile.keep_assignment)
639 ((Scheme_IR_Local *)var)->compile.keep_assignment = 2; /* keep permanently */
640 }
641
642 env = scheme_set_comp_env_name(env, SCHEME_STX_SYM(name));
643
644 val = compile_expr(body, env, 0);
645
646 set_undef = (env->flags & COMP_ENV_ALLOW_SET_UNDEFINED);
647
648 sb = MALLOC_ONE_TAGGED(Scheme_Set_Bang);
649 sb->so.type = scheme_set_bang_type;
650 sb->var = var;
651 sb->val = val;
652 sb->set_undef = set_undef;
653
654 return (Scheme_Object *)sb;
655 }
656
657 /**********************************************************************/
658 /* #%variable-reference */
659 /**********************************************************************/
660
ref_compile(Scheme_Object * form,Scheme_Comp_Env * env)661 static Scheme_Object *ref_compile (Scheme_Object *form, Scheme_Comp_Env *env)
662 {
663 Scheme_Object *var, *name, *rest, *pseudo_var;
664 int l, ok;
665
666 l = check_form(form, form);
667
668 /* retaining `pseudo-var' ensures that the environment stays
669 linked from the actual variable */
670 if ((l == 1) || !(env->flags & COMP_ENV_CHECKING_CONSTANT))
671 pseudo_var = (Scheme_Object *)scheme_make_ir_toplevel(-1, -1, 0);
672 else {
673 /* If the variable reference will be used only for
674 `variable-reference-constant?`, then we don't want a string
675 reference to the enclsoing instance. */
676 pseudo_var = scheme_false;
677 }
678
679 if (l == 1) {
680 var = scheme_false;
681 } else {
682 if (l != 2)
683 bad_form(form, l);
684
685 rest = SCHEME_STX_CDR(form);
686 name = SCHEME_STX_CAR(rest);
687 ok = SCHEME_STX_SYMBOLP(name);
688
689 if (!ok) {
690 scheme_wrong_syntax("#%variable-reference", name,
691 form,
692 "not an identifier");
693 return NULL;
694 }
695
696 var = scheme_compile_lookup(name, env, SCHEME_REFERENCING);
697
698 if (!SAME_TYPE(SCHEME_TYPE(var), scheme_ir_toplevel_type)
699 && !SAME_TYPE(SCHEME_TYPE(var), scheme_ir_local_type)
700 && !SCHEME_SYMBOLP(var)) { /* symbol means primitive instance */
701 scheme_wrong_syntax(NULL, name, form, "identifier does not refer to a variable");
702 }
703 }
704
705 {
706 Scheme_Object *o;
707 o = scheme_alloc_object();
708 o->type = scheme_varref_form_type;
709 SCHEME_PTR1_VAL(o) = var;
710 SCHEME_PTR2_VAL(o) = pseudo_var;
711 return o;
712 }
713 }
714
715 /**********************************************************************/
716 /* case-lambda */
717 /**********************************************************************/
718
scheme_unclose_case_lambda(Scheme_Object * expr,int mode)719 Scheme_Object *scheme_unclose_case_lambda(Scheme_Object *expr, int mode)
720 {
721 Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)expr;
722 Scheme_Closure *c;
723 int i;
724
725 for (i = cl->count; i--; ) {
726 c = (Scheme_Closure *)cl->array[i];
727 if (!ZERO_SIZED_CLOSUREP(c)) {
728 break;
729 }
730 }
731
732 if (i < 0) {
733 /* We can reconstruct a case-lambda syntactic form. */
734 Scheme_Case_Lambda *cl2;
735
736 cl2 = (Scheme_Case_Lambda *)scheme_malloc_tagged(sizeof(Scheme_Case_Lambda)
737 + ((cl->count - mzFLEX_DELTA) * sizeof(Scheme_Object*)));
738
739 cl2->so.type = scheme_case_lambda_sequence_type;
740 cl2->count = cl->count;
741 cl2->name = cl->name;
742
743 for (i = cl->count; i--; ) {
744 c = (Scheme_Closure *)cl->array[i];
745 cl2->array[i] = (Scheme_Object *)c->code;
746 }
747
748 if (mode == 2) {
749 /* sfs */
750 return (Scheme_Object *)cl2;
751 #ifdef MZ_USE_JIT
752 } else if (mode == 1) {
753 /* JIT */
754 return scheme_case_lambda_jit((Scheme_Object *)cl2);
755 #endif
756 } else
757 return (Scheme_Object *)cl2;
758 }
759
760 return expr;
761 }
762
case_lambda_check_line(Scheme_Object * line,Scheme_Object * form,Scheme_Comp_Env * env)763 static void case_lambda_check_line(Scheme_Object *line, Scheme_Object *form, Scheme_Comp_Env *env)
764 {
765 Scheme_Object *body, *args;
766
767 if (!SCHEME_STX_PAIRP(line))
768 scheme_wrong_syntax(NULL, line, form, NULL);
769
770 body = SCHEME_STX_CDR(line);
771 args = SCHEME_STX_CAR(line);
772
773 lambda_check_args(args, form, env);
774
775 if (!SCHEME_STX_PAIRP(body))
776 scheme_wrong_syntax(NULL, line, form, "%s",
777 SCHEME_STX_NULLP(body) ? "empty body not allowed" : IMPROPER_LIST_FORM);
778 }
779
case_lambda_compile(Scheme_Object * form,Scheme_Comp_Env * env)780 static Scheme_Object *case_lambda_compile (Scheme_Object *form, Scheme_Comp_Env *env)
781 {
782 Scheme_Object *list, *last, *c, *orig_form = form, *name;
783 Scheme_Case_Lambda *cl;
784 int i, count = 0;
785
786 form = SCHEME_STX_CDR(form);
787
788 env = check_name_property(orig_form, env);
789 name = scheme_build_closure_name(orig_form, env);
790
791 if (SCHEME_STX_NULLP(form)) {
792 /* Case where there are no cases... */
793 form = (Scheme_Object *)scheme_malloc_tagged(sizeof(Scheme_Case_Lambda)
794 - (mzFLEX_DELTA * sizeof(Scheme_Object*)));
795
796 form->type = scheme_case_lambda_sequence_type;
797 ((Scheme_Case_Lambda *)form)->count = 0;
798 ((Scheme_Case_Lambda *)form)->name = name;
799
800 if (scheme_has_method_property(orig_form)) {
801 /* See note in schpriv.h about the IS_METHOD hack */
802 if (!name)
803 name = scheme_false;
804 name = scheme_box(name);
805 ((Scheme_Case_Lambda *)form)->name = name;
806 }
807
808 return form;
809 }
810
811 if (!SCHEME_STX_PAIRP(form))
812 scheme_wrong_syntax(NULL, form, orig_form, NULL);
813 if (SCHEME_STX_NULLP(SCHEME_STX_CDR(form))) {
814 c = SCHEME_STX_CAR(form);
815
816 case_lambda_check_line(c, orig_form, env);
817
818 c = cons(lambda_symbol, c);
819 c = scheme_datum_to_syntax(c, orig_form, DTS_COPY_PROPS);
820
821 return lambda_compile(c, env);
822 }
823
824 list = last = NULL;
825 while (SCHEME_STX_PAIRP(form)) {
826 Scheme_Object *clause;
827 clause = SCHEME_STX_CAR(form);
828 case_lambda_check_line(clause, orig_form, env);
829
830 c = cons(lambda_symbol, clause);
831
832 c = scheme_datum_to_syntax(c, clause, 0);
833
834 c = cons(c, scheme_null);
835
836 if (list)
837 SCHEME_CDR(last) = c;
838 else
839 list = c;
840
841 last = c;
842 form = SCHEME_STX_CDR(form);
843
844 count++;
845 }
846
847 if (!SCHEME_STX_NULLP(form))
848 scheme_wrong_syntax(NULL, form, orig_form, NULL);
849
850 cl = (Scheme_Case_Lambda *)
851 scheme_malloc_tagged(sizeof(Scheme_Case_Lambda)
852 + (count - mzFLEX_DELTA) * sizeof(Scheme_Object *));
853 cl->so.type = scheme_case_lambda_sequence_type;
854 cl->count = count;
855 cl->name = SCHEME_TRUEP(name) ? name : NULL;
856
857 env = scheme_set_comp_env_name(env, NULL);
858
859 for (i = 0; i < count; i++) {
860 Scheme_Object *ce;
861 ce = SCHEME_CAR(list);
862 ce = compile_expr(ce, env, 0);
863 cl->array[i] = ce;
864 list = SCHEME_CDR(list);
865 }
866
867 if (scheme_has_method_property(orig_form)) {
868 Scheme_Lambda *lam;
869 /* Make sure no branch has 0 arguments: */
870 for (i = 0; i < count; i++) {
871 lam = (Scheme_Lambda *)cl->array[i];
872 if (!lam->num_params)
873 break;
874 }
875 if (i >= count) {
876 lam = (Scheme_Lambda *)cl->array[0];
877 SCHEME_LAMBDA_FLAGS(lam) |= LAMBDA_IS_METHOD;
878 }
879 }
880
881 return (Scheme_Object *)cl;
882 }
883
884 /**********************************************************************/
885 /* let, let-values, letrec, etc. */
886 /**********************************************************************/
887
make_header(Scheme_Object * first,int num_bindings,int num_clauses,int flags)888 static Scheme_IR_Let_Header *make_header(Scheme_Object *first, int num_bindings, int num_clauses,
889 int flags)
890 {
891 Scheme_IR_Let_Header *head;
892
893 head = MALLOC_ONE_TAGGED(Scheme_IR_Let_Header);
894 head->iso.so.type = scheme_ir_let_header_type;
895 head->body = first;
896 head->count = num_bindings;
897 head->num_clauses = num_clauses;
898 SCHEME_LET_FLAGS(head) = flags;
899
900 return head;
901 }
902
do_let_compile(Scheme_Object * form,Scheme_Comp_Env * origenv,char * formname,int recursive)903 static Scheme_Object *do_let_compile (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
904 int recursive)
905 {
906 Scheme_Object *bindings, *l, *binding, *name, **names, *forms;
907 int num_clauses, num_bindings, i, k, m, pre_k, mutate_frame = 0, *use_box;
908 Scheme_Comp_Env *frame, *rhs_env;
909 Scheme_Object *first = NULL;
910 Scheme_IR_Let_Value *last = NULL, *lv;
911 Scheme_IR_Local *var, **vars;
912 DupCheckRecord r;
913 Scheme_IR_Let_Header *head;
914
915 i = check_form(form, form);
916 if (i != 3)
917 bad_form(form, i);
918
919 bindings = SCHEME_STX_CDR(form);
920 bindings = SCHEME_STX_CAR(bindings);
921 num_clauses = scheme_stx_proper_list_length(bindings);
922
923 if (num_clauses < 0)
924 scheme_wrong_syntax(NULL, bindings, form, NULL);
925
926 /* forms ends up being the let body */
927 forms = SCHEME_STX_CDR(form);
928 forms = SCHEME_STX_CDR(forms);
929 forms = SCHEME_STX_CAR(forms);
930
931 origenv = check_name_property(form, origenv);
932
933 if (!num_clauses)
934 return compile_expr(forms, origenv, 0);
935
936 num_bindings = 0;
937 l = bindings;
938 while (!SCHEME_STX_NULLP(l)) {
939 Scheme_Object *clause, *names, *rest;
940 int num_names;
941
942 clause = SCHEME_STX_CAR(l);
943
944 if (!SCHEME_STX_PAIRP(clause))
945 rest = NULL;
946 else {
947 rest = SCHEME_STX_CDR(clause);
948 if (!SCHEME_STX_PAIRP(rest))
949 rest = NULL;
950 else {
951 rest = SCHEME_STX_CDR(rest);
952 if (!SCHEME_STX_NULLP(rest))
953 rest = NULL;
954 }
955 }
956 if (!rest)
957 scheme_wrong_syntax(NULL, clause, form, NULL);
958
959 names = SCHEME_STX_CAR(clause);
960
961 num_names = scheme_stx_proper_list_length(names);
962 if (num_names < 0)
963 scheme_wrong_syntax(NULL, names, form, NULL);
964
965 num_bindings += num_names;
966
967 l = SCHEME_STX_CDR(l);
968 }
969
970 names = MALLOC_N(Scheme_Object *, num_bindings);
971
972 frame = scheme_set_comp_env_name(origenv, NULL);
973
974 if (recursive) {
975 use_box = MALLOC_N_ATOMIC(int, 1);
976 *use_box = -1;
977 } else
978 use_box = NULL;
979
980 scheme_begin_dup_symbol_check(&r);
981
982 k = 0;
983
984 for (i = 0; i < num_clauses; i++) {
985 if (!SCHEME_STX_PAIRP(bindings))
986 scheme_wrong_syntax(NULL, bindings, form, NULL);
987 binding = SCHEME_STX_CAR(bindings);
988 if (!SCHEME_STX_PAIRP(binding) || !SCHEME_STX_PAIRP(SCHEME_STX_CDR(binding)))
989 scheme_wrong_syntax(NULL, binding, form, NULL);
990
991 {
992 Scheme_Object *rest;
993 rest = SCHEME_STX_CDR(binding);
994 if (!SCHEME_STX_NULLP(SCHEME_STX_CDR(rest)))
995 scheme_wrong_syntax(NULL, binding, form, NULL);
996 }
997
998 pre_k = k;
999
1000 name = SCHEME_STX_CAR(binding);
1001 while (!SCHEME_STX_NULLP(name)) {
1002 Scheme_Object *n;
1003 n = SCHEME_STX_CAR(name);
1004 names[k] = n;
1005 scheme_check_identifier(NULL, names[k], NULL, form);
1006 scheme_dup_symbol_check(&r, NULL, names[k], "binding", form);
1007 k++;
1008 name = SCHEME_STX_CDR(name);
1009 }
1010
1011 vars = MALLOC_N(Scheme_IR_Local*, k-pre_k);
1012
1013 lv = MALLOC_ONE_TAGGED(Scheme_IR_Let_Value);
1014 lv->iso.so.type = scheme_ir_let_value_type;
1015 if (!last)
1016 first = (Scheme_Object *)lv;
1017 else
1018 last->body = (Scheme_Object *)lv;
1019 last = lv;
1020 lv->count = (k - pre_k);
1021 lv->vars = vars;
1022
1023 {
1024 Scheme_Object *rhs;
1025 rhs = SCHEME_STX_CDR(binding);
1026 rhs = SCHEME_STX_CAR(rhs);
1027 if (!recursive) {
1028 if (lv->count == 1)
1029 rhs_env = scheme_set_comp_env_name(origenv, names[pre_k]);
1030 else
1031 rhs_env = scheme_set_comp_env_name(origenv, NULL);
1032 rhs = SCHEME_STX_CDR(binding);
1033 rhs = SCHEME_STX_CAR(rhs);
1034 rhs = compile_expr(rhs, rhs_env, 0);
1035 }
1036 lv->value = rhs;
1037 }
1038
1039 for (m = pre_k; m < k; m++) {
1040 var = scheme_make_ir_local(names[m]);
1041 if (recursive) {
1042 var->mode = SCHEME_VAR_MODE_COMPILE;
1043 var->compile.use_box = use_box;
1044 var->compile.use_position = m;
1045 var->compile.keep_assignment = 1;
1046 }
1047 vars[m-pre_k] = var;
1048 frame = scheme_extend_comp_env(frame, names[m], (Scheme_Object *)var, mutate_frame, 0);
1049 mutate_frame = 1;
1050 }
1051
1052 bindings = SCHEME_STX_CDR(bindings);
1053 }
1054
1055 head = make_header(first, num_bindings, num_clauses,
1056 (recursive ? SCHEME_LET_RECURSIVE : 0));
1057
1058 if (recursive) {
1059 int prev_might_invoke = 0, j;
1060 int group_clauses = 0;
1061 Scheme_Object *rhs;
1062
1063 k = 0;
1064 lv = (Scheme_IR_Let_Value *)first;
1065 for (i = 0; i < num_clauses; i++, lv = (Scheme_IR_Let_Value *)lv->body) {
1066 rhs = lv->value;
1067 if (lv->count == 1)
1068 rhs_env = scheme_set_comp_env_name(frame, names[k]);
1069 else
1070 rhs_env = scheme_set_comp_env_name(frame, NULL);
1071 rhs = compile_expr(rhs, rhs_env, 0);
1072 lv->value = rhs;
1073
1074 for (j = lv->count; j--; ) {
1075 if (lv->vars[j]->compile.keep_assignment < 2)
1076 lv->vars[j]->compile.keep_assignment = 0;
1077 }
1078
1079 /* Record when this binding doesn't use any or later bindings in
1080 the same set. Break bindings into smaller sets based on this
1081 information, we have to be conservative as reflected by
1082 scheme_might_invoke_call_cc(). Implement splitting by
1083 recording with SCHEME_IRLV_NO_GROUP_LATER_USES and check
1084 again at the end. */
1085 if (!prev_might_invoke && !scheme_might_invoke_call_cc(rhs)) {
1086 group_clauses++;
1087 if ((group_clauses == 1) && (*use_box < k)) {
1088 /* A clause that should be in its own `let' */
1089 SCHEME_IRLV_FLAGS(lv) |= SCHEME_IRLV_NO_GROUP_USES;
1090 group_clauses = 0;
1091 } else if (*use_box < (k + lv->count)) {
1092 /* End a recursive `letrec' group */
1093 SCHEME_IRLV_FLAGS(lv) |= SCHEME_IRLV_NO_GROUP_LATER_USES;
1094 group_clauses = 0;
1095 }
1096 } else
1097 prev_might_invoke = 1;
1098
1099 k += lv->count;
1100 }
1101
1102 if (!prev_might_invoke) {
1103 Scheme_IR_Let_Header *current_head = head;
1104 Scheme_IR_Let_Value *next = NULL;
1105 int group_count = 0;
1106 lv = (Scheme_IR_Let_Value *)first;
1107 group_clauses = 0;
1108 for (i = 0; i < num_clauses; i++, lv = next) {
1109 next = (Scheme_IR_Let_Value *)lv->body;
1110 group_clauses++;
1111 group_count += lv->count;
1112 if (SCHEME_IRLV_FLAGS(lv) & (SCHEME_IRLV_NO_GROUP_USES
1113 | SCHEME_IRLV_NO_GROUP_LATER_USES)) {
1114 /* A clause that should be in its own `let' */
1115 Scheme_IR_Let_Header *next_head;
1116 int single = (SCHEME_IRLV_FLAGS(lv) & SCHEME_IRLV_NO_GROUP_USES);
1117 MZ_ASSERT(!single || (group_clauses == 1));
1118 if (current_head->num_clauses - group_clauses) {
1119 next_head = make_header(lv->body,
1120 current_head->count - group_count,
1121 current_head->num_clauses - group_clauses,
1122 SCHEME_LET_RECURSIVE);
1123 lv->body = (Scheme_Object *)next_head;
1124 current_head->num_clauses = group_clauses;
1125 current_head->count = group_count;
1126 } else
1127 next_head = NULL;
1128 if (single)
1129 SCHEME_LET_FLAGS(current_head) -= SCHEME_LET_RECURSIVE;
1130 current_head = next_head;
1131 group_clauses = 0;
1132 group_count = 0;
1133 }
1134 }
1135 }
1136 }
1137
1138 frame = scheme_set_comp_env_name(frame, origenv->value_name);
1139
1140 forms = compile_expr(forms, frame, 0);
1141 last->body = forms;
1142
1143 return (Scheme_Object *)head;
1144 }
1145
let_values_compile(Scheme_Object * form,Scheme_Comp_Env * env)1146 static Scheme_Object *let_values_compile (Scheme_Object *form, Scheme_Comp_Env *env)
1147 {
1148 return do_let_compile(form, env, "let-values", 0);
1149 }
1150
letrec_values_compile(Scheme_Object * form,Scheme_Comp_Env * env)1151 static Scheme_Object *letrec_values_compile (Scheme_Object *form, Scheme_Comp_Env *env)
1152 {
1153 return do_let_compile(form, env, "letrec-values", 1);
1154 }
1155
1156 /**********************************************************************/
1157 /* begin, begin0, implicit begins */
1158 /**********************************************************************/
1159
scheme_compiled_void()1160 Scheme_Object *scheme_compiled_void()
1161 {
1162 return scheme_void;
1163 }
1164
do_begin_compile(char * name,Scheme_Object * form,Scheme_Comp_Env * env,int zero)1165 static Scheme_Object *do_begin_compile(char *name,
1166 Scheme_Object *form, Scheme_Comp_Env *env,
1167 int zero)
1168 {
1169 Scheme_Comp_Env *nontail_env;
1170 Scheme_Object *forms, *body;
1171
1172 forms = SCHEME_STX_CDR(form);
1173
1174 if (SCHEME_STX_NULLP(forms)) {
1175 if (!zero)
1176 return scheme_compiled_void();
1177 scheme_wrong_syntax(NULL, NULL, form, "empty form not allowed");
1178 return NULL;
1179 }
1180
1181 check_form(form, form);
1182
1183 env = check_name_property(form, env);
1184 nontail_env = scheme_set_comp_env_name(env, NULL);
1185
1186 /* if the `begin` has only one expression inside, drop the `begin`;
1187 this is allowed even for `begin0`, where the initial expression
1188 is considered in tail position if it's syntactically the only
1189 expression */
1190 if (SCHEME_STX_NULLP(SCHEME_STX_CDR(forms))) {
1191 forms = SCHEME_STX_CAR(forms);
1192 return compile_expr(forms, env, 0);
1193 }
1194
1195 if (zero) {
1196 Scheme_Object *first, *rest;
1197
1198 first = SCHEME_STX_CAR(forms);
1199 first = compile_expr(first, env, 0);
1200 rest = SCHEME_STX_CDR(forms);
1201 rest = compile_list(rest, nontail_env, nontail_env, nontail_env, 0);
1202
1203 body = cons(first, rest);
1204 } else {
1205 body = compile_list(forms, nontail_env, nontail_env, env, 0);
1206 }
1207
1208 forms = scheme_make_sequence_compilation(body, zero ? -1 : 1, 0);
1209
1210 return forms;
1211 }
1212
begin_compile(Scheme_Object * form,Scheme_Comp_Env * env)1213 static Scheme_Object *begin_compile (Scheme_Object *form, Scheme_Comp_Env *env)
1214 {
1215 return do_begin_compile("begin", form, env, 0);
1216 }
1217
begin0_compile(Scheme_Object * form,Scheme_Comp_Env * env)1218 static Scheme_Object *begin0_compile (Scheme_Object *form, Scheme_Comp_Env *env)
1219 {
1220 return do_begin_compile("begin0", form, env, 1);
1221 }
1222
malloc_big_sequence(int count)1223 static Scheme_Sequence *malloc_big_sequence(int count)
1224 {
1225 intptr_t sz;
1226 Scheme_Sequence *seq;
1227
1228 sz = scheme_check_overflow((count - mzFLEX_DELTA), sizeof(Scheme_Object *), sizeof(Scheme_Sequence));
1229 seq = (Scheme_Sequence *)scheme_malloc_fail_ok(scheme_malloc_tagged, sz);
1230 if (!seq) scheme_signal_error("out of memory allocating sequence bytecode");
1231
1232 return seq;
1233 }
1234
scheme_malloc_sequence(int count)1235 Scheme_Sequence *scheme_malloc_sequence(int count) XFORM_ASSERT_NO_CONVERSION
1236 {
1237 if (count < 4096)
1238 return (Scheme_Sequence *)scheme_malloc_tagged(sizeof(Scheme_Sequence)
1239 + (count - mzFLEX_DELTA)
1240 * sizeof(Scheme_Object *));
1241 else
1242 return malloc_big_sequence(count);
1243 }
1244
scheme_make_sequence_compilation(Scheme_Object * seq,int opt,int resolved)1245 Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *seq, int opt, int resolved)
1246 {
1247 /* We have to be defensive in processing `seq'; it might be bad due
1248 to a bad .zo */
1249 Scheme_Object *list, *v, *good;
1250 Scheme_Sequence *o;
1251 int count, i, k, total, last, first, setgood;
1252 Scheme_Type type;
1253
1254 type = scheme_sequence_type;
1255
1256 list = seq;
1257 count = i = 0;
1258 good = NULL;
1259 total = 0;
1260 first = 1;
1261 setgood = 1;
1262 while (SCHEME_PAIRP(list)) {
1263 v = SCHEME_CAR(list);
1264 list = SCHEME_CDR(list);
1265 last = SCHEME_NULLP(list);
1266
1267 if (((opt > 0) || !first) && SAME_TYPE(SCHEME_TYPE(v), type)) {
1268 /* "Inline" nested begins */
1269 count += ((Scheme_Sequence *)v)->count;
1270 total++;
1271 } else if (opt
1272 && (((opt > 0) && !last) || ((opt < 0) && !first))
1273 && scheme_omittable_expr(v, -1, -1,
1274 (resolved ? OMITTABLE_RESOLVED : OMITTABLE_KEEP_VARS),
1275 NULL, NULL)) {
1276 /* A value that is not the result. We'll drop it. */
1277 total++;
1278 } else {
1279 if (setgood)
1280 good = v;
1281 count++;
1282 total++;
1283 }
1284 i++;
1285 if (first) {
1286 if (opt < 0)
1287 setgood = 0;
1288 first = 0;
1289 }
1290 }
1291
1292 if (!SCHEME_NULLP(list))
1293 return NULL; /* bad .zo */
1294
1295 if (!count)
1296 return scheme_compiled_void();
1297
1298 if (count == 1) {
1299 if (opt < -1) {
1300 /* can't optimize away a begin0 reading a .zo time */
1301 } else if ((opt < 0)
1302 && !scheme_omittable_expr(SCHEME_CAR(seq), 1, -1,
1303 (resolved ? OMITTABLE_RESOLVED : OMITTABLE_KEEP_VARS),
1304 NULL, NULL)) {
1305 /* We can't optimize (begin0 expr cont) to expr because
1306 exp is not in tail position in the original (so we'd mess
1307 up continuation marks). */
1308 } else
1309 return good;
1310 }
1311
1312 o = scheme_malloc_sequence(count);
1313
1314 o->so.type = ((opt < 0) ? scheme_begin0_sequence_type : scheme_sequence_type);
1315 o->count = count;
1316
1317 --total;
1318 for (i = k = 0; i < count; k++) {
1319 v = SCHEME_CAR(seq);
1320 seq = SCHEME_CDR(seq);
1321
1322 if (((opt > 0) || k) && SAME_TYPE(SCHEME_TYPE(v), type)) {
1323 int c, j;
1324 Scheme_Object **a;
1325
1326 c = ((Scheme_Sequence *)v)->count;
1327 a = ((Scheme_Sequence *)v)->array; /* <-- mismaligned for precise GC */
1328 for (j = 0; j < c; j++) {
1329 o->array[i++] = a[j];
1330 }
1331 } else if (opt
1332 && (((opt > 0) && (k < total))
1333 || ((opt < 0) && k))
1334 && scheme_omittable_expr(v, -1, -1,
1335 (resolved ? OMITTABLE_RESOLVED : OMITTABLE_KEEP_VARS),
1336 NULL, NULL)) {
1337 /* Value not the result. Do nothing. */
1338 } else
1339 o->array[i++] = v;
1340 }
1341
1342 return (Scheme_Object *)o;
1343 }
1344
1345 /*========================================================================*/
1346 /* applications */
1347 /*========================================================================*/
1348
scheme_get_eval_type(Scheme_Object * obj)1349 int scheme_get_eval_type(Scheme_Object *obj)
1350 /* Categories for short-cutting recursive calls to the evaluator */
1351 {
1352 Scheme_Type type;
1353
1354 type = SCHEME_TYPE(obj);
1355
1356 if (type > _scheme_values_types_)
1357 return SCHEME_EVAL_CONSTANT;
1358 else if (SAME_TYPE(type, scheme_ir_local_type)
1359 || SAME_TYPE(type, scheme_local_type))
1360 return SCHEME_EVAL_LOCAL;
1361 else if (SAME_TYPE(type, scheme_local_unbox_type))
1362 return SCHEME_EVAL_LOCAL_UNBOX;
1363 else if (SAME_TYPE(type, scheme_toplevel_type))
1364 return SCHEME_EVAL_GLOBAL;
1365 else
1366 return SCHEME_EVAL_GENERAL;
1367 }
1368
scheme_try_apply(Scheme_Object * f,Scheme_Object * args,Optimize_Info * info)1369 Scheme_Object *scheme_try_apply(Scheme_Object *f, Scheme_Object *args, Optimize_Info *info)
1370 /* Apply `f' to `args' and ignore failures --- used for constant
1371 folding attempts */
1372 {
1373 Scheme_Object * volatile result;
1374 Scheme_Object * volatile exn = NULL;
1375 mz_jmp_buf *savebuf, newbuf;
1376
1377 scheme_current_thread->reading_delayed = NULL;
1378 scheme_current_thread->constant_folding = (info ? info : (Optimize_Info *)scheme_false);
1379 savebuf = scheme_current_thread->error_buf;
1380 scheme_current_thread->error_buf = &newbuf;
1381
1382 if (scheme_setjmp(newbuf)) {
1383 result = NULL;
1384 exn = scheme_current_thread->reading_delayed;
1385 } else
1386 result = _scheme_apply_to_list(f, args);
1387
1388 scheme_current_thread->error_buf = savebuf;
1389 scheme_current_thread->constant_folding = NULL;
1390 scheme_current_thread->reading_delayed = NULL;
1391
1392 if (scheme_current_thread->cjs.is_kill) {
1393 scheme_longjmp(*scheme_current_thread->error_buf, 1);
1394 }
1395
1396 if (exn)
1397 scheme_raise(exn);
1398
1399 return result;
1400 }
1401
foldable_body(Scheme_Object * f)1402 static int foldable_body(Scheme_Object *f)
1403 {
1404 Scheme_Lambda *d;
1405
1406 d = SCHEME_CLOSURE_CODE(f);
1407
1408 scheme_delay_load_closure(d);
1409
1410 return (SCHEME_TYPE(d->body) > _scheme_values_types_);
1411 }
1412
scheme_is_foldable_prim(Scheme_Object * f)1413 int scheme_is_foldable_prim(Scheme_Object *f)
1414 {
1415 if (SCHEME_PRIMP(f)
1416 && ((((Scheme_Primitive_Proc *)f)->pp.flags & SCHEME_PRIM_OPT_MASK)
1417 == SCHEME_PRIM_OPT_FOLDING))
1418 return 1;
1419
1420 if (SCHEME_CLSD_PRIMP(f)
1421 && ((((Scheme_Closed_Primitive_Proc *)f)->pp.flags & SCHEME_PRIM_OPT_MASK)
1422 == SCHEME_PRIM_OPT_FOLDING))
1423 return 1;
1424
1425 return 0;
1426 }
1427
scheme_make_application(Scheme_Object * v,Optimize_Info * info)1428 Scheme_Object *scheme_make_application(Scheme_Object *v, Optimize_Info *info)
1429 {
1430 Scheme_Object *o;
1431 int i, nv;
1432 volatile int n;
1433
1434 o = v;
1435 n = 0;
1436 nv = 0;
1437 while (!SCHEME_NULLP(o)) {
1438 Scheme_Type type;
1439
1440 n++;
1441 type = SCHEME_TYPE(SCHEME_CAR(o));
1442 if (type < _scheme_ir_values_types_)
1443 nv = 1;
1444 o = SCHEME_CDR(o);
1445 }
1446
1447 if (!nv) {
1448 /* They're all values. Applying folding prim or closure? */
1449 Scheme_Object *f;
1450
1451 f = SCHEME_CAR(v);
1452
1453 if (scheme_is_foldable_prim(f)
1454 || (SAME_TYPE(SCHEME_TYPE(f), scheme_closure_type)
1455 && (foldable_body(f)))) {
1456 f = scheme_try_apply(f, SCHEME_CDR(v), info);
1457
1458 if (f)
1459 return f;
1460 }
1461 }
1462
1463 if (n == 2) {
1464 Scheme_App2_Rec *app;
1465
1466 app = MALLOC_ONE_TAGGED(Scheme_App2_Rec);
1467 app->iso.so.type = scheme_application2_type;
1468
1469 app->rator = SCHEME_CAR(v);
1470 v = SCHEME_CDR(v);
1471 app->rand = SCHEME_CAR(v);
1472
1473 return (Scheme_Object *)app;
1474 } else if (n == 3) {
1475 Scheme_App3_Rec *app;
1476
1477 app = MALLOC_ONE_TAGGED(Scheme_App3_Rec);
1478 app->iso.so.type = scheme_application3_type;
1479
1480 app->rator = SCHEME_CAR(v);
1481 v = SCHEME_CDR(v);
1482 app->rand1 = SCHEME_CAR(v);
1483 v = SCHEME_CDR(v);
1484 app->rand2 = SCHEME_CAR(v);
1485
1486 return (Scheme_Object *)app;
1487 } else {
1488 Scheme_App_Rec *app;
1489
1490 app = scheme_malloc_application(n);
1491
1492 for (i = 0; i < n; i++, v = SCHEME_CDR(v)) {
1493 app->args[i] = SCHEME_CAR(v);
1494 }
1495
1496 return (Scheme_Object *)app;
1497 }
1498 }
1499
scheme_malloc_application(int n)1500 Scheme_App_Rec *scheme_malloc_application(int n)
1501 {
1502 Scheme_App_Rec *app;
1503 intptr_t size;
1504
1505 if (n < 0) {
1506 scheme_signal_error("bad application count");
1507 app = NULL;
1508 } else if (n > 4096) {
1509 size = scheme_check_overflow(n,
1510 sizeof(char),
1511 (sizeof(Scheme_App_Rec)
1512 + ((n - mzFLEX_DELTA) * sizeof(Scheme_Object *))));
1513 app = (Scheme_App_Rec *)scheme_malloc_fail_ok(scheme_malloc_tagged, size);
1514 if (!app) scheme_signal_error("out of memory allocating application bytecode");
1515 } else {
1516 size = (sizeof(Scheme_App_Rec)
1517 + ((n - mzFLEX_DELTA) * sizeof(Scheme_Object *))
1518 + n * sizeof(char));
1519 app = (Scheme_App_Rec *)scheme_malloc_tagged(size);
1520 }
1521
1522 app->iso.so.type = scheme_application_type;
1523
1524 app->num_args = n - 1;
1525
1526 return app;
1527 }
1528
scheme_finish_application(Scheme_App_Rec * app)1529 void scheme_finish_application(Scheme_App_Rec *app)
1530 {
1531 int i, devals, n;
1532
1533 n = app->num_args + 1;
1534
1535 devals = sizeof(Scheme_App_Rec) + ((app->num_args + 1 - mzFLEX_DELTA) * sizeof(Scheme_Object *));
1536
1537 for (i = 0; i < n; i++) {
1538 char etype;
1539 etype = scheme_get_eval_type(app->args[i]);
1540 ((char *)app XFORM_OK_PLUS devals)[i] = etype;
1541 }
1542 }
1543
1544 /*========================================================================*/
1545 /* application */
1546 /*========================================================================*/
1547
1548 static Scheme_Object *
compile_list(Scheme_Object * form,Scheme_Comp_Env * first_env,Scheme_Comp_Env * env,Scheme_Comp_Env * last_env,int start_app_position)1549 compile_list(Scheme_Object *form,
1550 Scheme_Comp_Env *first_env, Scheme_Comp_Env *env, Scheme_Comp_Env *last_env,
1551 int start_app_position)
1552 {
1553 int len;
1554
1555 len = scheme_stx_proper_list_length(form);
1556
1557 if (!len) {
1558 return scheme_null;
1559 } else if (len > 0) {
1560 int i;
1561 Scheme_Object *c, *p, *comp_first, *comp_last, *first, *rest;
1562
1563 comp_first = comp_last = NULL;
1564
1565 for (i = 0, rest = form; i < len; i++) {
1566 first = SCHEME_STX_CAR(rest);
1567 rest = SCHEME_STX_CDR(rest);
1568
1569 c = compile_expr(first,
1570 (!i ? first_env : ((i == (len-1)) ? last_env : env)),
1571 !i && start_app_position);
1572
1573 p = scheme_make_pair(c, scheme_null);
1574 if (comp_last)
1575 SCHEME_CDR(comp_last) = p;
1576 else
1577 comp_first = p;
1578 comp_last = p;
1579
1580 if (!i && start_app_position && (len == 2)
1581 && SAME_OBJ(c, scheme_varref_const_p_proc))
1582 last_env = scheme_set_comp_env_flags(last_env, COMP_ENV_CHECKING_CONSTANT);
1583 }
1584
1585 return comp_first;
1586 } else {
1587 scheme_signal_error("internal error: compile-list on non-list");
1588 return NULL;
1589 }
1590 }
1591
compile_plain_app(Scheme_Object * form,Scheme_Comp_Env * env)1592 static Scheme_Object *compile_plain_app(Scheme_Object *form, Scheme_Comp_Env *env)
1593 {
1594 Scheme_Object *result, *rator;
1595 int len;
1596
1597 len = scheme_stx_proper_list_length(form);
1598
1599 if (len < 0)
1600 scheme_wrong_syntax("application", NULL, form, NULL);
1601
1602 env = scheme_set_comp_env_name(env, NULL);
1603
1604 form = compile_list(form, env, env, env, 1);
1605
1606 result = scheme_make_application(form, NULL);
1607
1608 /* Record which application this is for a variable that is used only in
1609 application positions. */
1610 if (SAME_TYPE(SCHEME_TYPE(result), scheme_application_type))
1611 rator = ((Scheme_App_Rec *)result)->args[0];
1612 else if (SAME_TYPE(SCHEME_TYPE(result), scheme_application2_type))
1613 rator = ((Scheme_App2_Rec *)result)->rator;
1614 else if (SAME_TYPE(SCHEME_TYPE(result), scheme_application3_type))
1615 rator = ((Scheme_App3_Rec *)result)->rator;
1616 else
1617 rator = NULL;
1618 if (rator) {
1619 rator = scheme_optimize_extract_tail_inside(rator);
1620 if (SAME_TYPE(SCHEME_TYPE(rator), scheme_ir_local_type)) {
1621 if (SCHEME_VAR(rator)->use_count < SCHEME_USE_COUNT_INF) {
1622 if (SAME_TYPE(SCHEME_TYPE(result), scheme_application_type))
1623 SCHEME_APPN_FLAGS((Scheme_App_Rec *)result) |= SCHEME_VAR(rator)->use_count;
1624 else if (SAME_TYPE(SCHEME_TYPE(result), scheme_application2_type))
1625 SCHEME_APPN_FLAGS((Scheme_App2_Rec *)result) |= SCHEME_VAR(rator)->use_count;
1626 else if (SAME_TYPE(SCHEME_TYPE(result), scheme_application3_type))
1627 SCHEME_APPN_FLAGS((Scheme_App3_Rec *)result) |= SCHEME_VAR(rator)->use_count;
1628 }
1629 }
1630 }
1631
1632 return result;
1633 }
1634
arg_count(Scheme_Object * lam)1635 static int arg_count(Scheme_Object *lam)
1636 {
1637 Scheme_Object *l, *id, *form = lam;
1638 int cnt = 0;
1639 DupCheckRecord r;
1640
1641 lam = SCHEME_STX_CDR(lam);
1642 if (!SCHEME_STX_PAIRP(lam)) return -1;
1643
1644 l = SCHEME_STX_CAR(lam);
1645
1646 lam = SCHEME_STX_CDR(lam);
1647 if (!SCHEME_STX_PAIRP(lam)) return -1;
1648
1649 while (SCHEME_STX_PAIRP(lam)) { lam = SCHEME_STX_CDR(lam); }
1650 if (!SCHEME_STX_NULLP(lam)) return -1;
1651
1652 scheme_begin_dup_symbol_check(&r);
1653
1654 while (SCHEME_STX_PAIRP(l)) {
1655 id = SCHEME_STX_CAR(l);
1656 scheme_check_identifier("lambda", id, "argument", form);
1657 scheme_dup_symbol_check(&r, NULL, id, "argument", form);
1658 l = SCHEME_STX_CDR(l);
1659 cnt++;
1660 }
1661 if (!SCHEME_STX_NULLP(l)) return -1;
1662
1663 return cnt;
1664 }
1665
compile_app(Scheme_Object * orig_form,Scheme_Comp_Env * env)1666 static Scheme_Object *compile_app(Scheme_Object *orig_form, Scheme_Comp_Env *env)
1667 {
1668 Scheme_Object *form, *forms, *orig_vname = env->value_name;
1669
1670 forms = orig_form;
1671 form = forms;
1672
1673 if (SCHEME_STX_NULLP(form)) {
1674 /* Compile/expand empty application to null list: */
1675 return scheme_null;
1676 } else if (!SCHEME_STX_PAIRP(form)) {
1677 /* will end in error */
1678 return compile_plain_app(form, env);
1679 } else {
1680 Scheme_Object *name, *origname, *orig_rest_form, *rest_form;
1681 name = SCHEME_STX_CAR(form);
1682 origname = name;
1683
1684 /* look for ((lambda (x ...) ....) ....) or ((lambda x ....) ....) */
1685 if (SAME_OBJ(SCHEME_STX_SYM(name), lambda_symbol)) {
1686 Scheme_Object *argsnbody;
1687
1688 argsnbody = SCHEME_STX_CDR(name);
1689 if (SCHEME_STX_PAIRP(argsnbody)) {
1690 Scheme_Object *args, *body;
1691
1692 args = SCHEME_STX_CAR(argsnbody);
1693 body = SCHEME_STX_CDR(argsnbody);
1694
1695 if (SCHEME_STX_PAIRP(body)) {
1696 int pl;
1697 pl = scheme_stx_proper_list_length(args);
1698 if ((pl >= 0) || SCHEME_STX_SYMBOLP(args)) {
1699 Scheme_Object *bindings = scheme_null, *last = NULL;
1700 Scheme_Object *rest;
1701 int al;
1702
1703 rest = SCHEME_STX_CDR(form);
1704 al = scheme_stx_proper_list_length(rest);
1705
1706 if ((pl < 0) || (al == pl)) {
1707 DupCheckRecord r;
1708
1709 scheme_begin_dup_symbol_check(&r);
1710
1711 while (!SCHEME_STX_NULLP(args)) {
1712 Scheme_Object *v, *n;
1713
1714 if (pl < 0)
1715 n = args;
1716 else
1717 n = SCHEME_STX_CAR(args);
1718 scheme_check_identifier("lambda", n, NULL, name);
1719
1720 /* If we don't check here, the error is in terms of `let': */
1721 scheme_dup_symbol_check(&r, NULL, n, "argument", name);
1722
1723 if (pl < 0) {
1724 v = scheme_intern_symbol("list");
1725 v = cons(v, rest);
1726 } else
1727 v = SCHEME_STX_CAR(rest);
1728 v = cons(cons(cons(n, scheme_null), cons(v, scheme_null)), scheme_null);
1729 if (last)
1730 SCHEME_CDR(last) = v;
1731 else
1732 bindings = v;
1733
1734 last = v;
1735 if (pl < 0) {
1736 /* rator is (lambda rest-x ....) */
1737 break;
1738 } else {
1739 args = SCHEME_STX_CDR(args);
1740 rest = SCHEME_STX_CDR(rest);
1741 }
1742 }
1743
1744 body = scheme_datum_to_syntax(cons(let_values_symbol,
1745 cons(bindings, body)),
1746 form,
1747 DTS_COPY_PROPS);
1748
1749 env = scheme_set_comp_env_name(env, orig_vname);
1750
1751 return compile_expr(body, env, 0);
1752 }
1753 }
1754 }
1755 }
1756 }
1757
1758 orig_rest_form = SCHEME_STX_CDR(form);
1759
1760 /* Look for (call-with-values (lambda () M) (lambda (id ...) N)) */
1761 if (SAME_OBJ(SCHEME_STX_SYM(name), call_with_values_symbol)) {
1762 Scheme_Object *at_first, *at_second, *the_end;
1763 at_first = SCHEME_STX_CDR(form);
1764 if (SCHEME_STX_PAIRP(at_first)) {
1765 at_second = SCHEME_STX_CDR(at_first);
1766 if (SCHEME_STX_PAIRP(at_second)) {
1767 the_end = SCHEME_STX_CDR(at_second);
1768 if (SCHEME_STX_NULLP(the_end)) {
1769 Scheme_Object *first;
1770 first = SCHEME_STX_CAR(at_first);
1771 if (SCHEME_STX_PAIRP(first)
1772 && SAME_OBJ(SCHEME_STX_SYM(SCHEME_STX_CAR(first)), lambda_symbol)
1773 && (arg_count(first) == 0)) {
1774 Scheme_Object *second;
1775 second = SCHEME_STX_CAR(at_second);
1776 if (SCHEME_STX_PAIRP(second)
1777 && SAME_OBJ(SCHEME_STX_SYM(SCHEME_STX_CAR(second)), lambda_symbol)
1778 && (arg_count(second) >= 0)) {
1779 Scheme_Object *lhs;
1780 second = SCHEME_STX_CDR(second);
1781 lhs = SCHEME_STX_CAR(second);
1782 second = SCHEME_STX_CDR(second);
1783 first = SCHEME_STX_CDR(first);
1784 first = SCHEME_STX_CDR(first);
1785 first = icons(begin_symbol, first);
1786 first = scheme_datum_to_syntax(first, at_first, DTS_COPY_PROPS);
1787 second = icons(begin_symbol, second);
1788 second = scheme_datum_to_syntax(second, at_second, DTS_COPY_PROPS);
1789 /* Convert to let-values: */
1790 name = icons(let_values_symbol,
1791 icons(icons(icons(lhs, icons(first, scheme_null)),
1792 scheme_null),
1793 icons(second, scheme_null)));
1794 form = scheme_datum_to_syntax(name, forms, DTS_COPY_PROPS);
1795 env->value_name = orig_vname;
1796 return compile_expr(form, env, 0);
1797 }
1798 }
1799 }
1800 }
1801 }
1802 rest_form = at_first;
1803 } else {
1804 rest_form = orig_rest_form;
1805 }
1806
1807 if (NOT_SAME_OBJ(name, origname)
1808 || NOT_SAME_OBJ(rest_form, orig_rest_form)) {
1809 form = scheme_datum_to_syntax(scheme_make_pair(name, rest_form), forms, DTS_COPY_PROPS);
1810 }
1811
1812 return compile_plain_app(form, env);
1813 }
1814 }
1815
1816 /*========================================================================*/
1817 /* expression compilation dispatcher */
1818 /*========================================================================*/
1819
compile_expr_k(void)1820 static Scheme_Object *compile_expr_k(void)
1821 {
1822 Scheme_Thread *p = scheme_current_thread;
1823 Scheme_Object *form = (Scheme_Object *)p->ku.k.p1;
1824 Scheme_Comp_Env *env = (Scheme_Comp_Env *)p->ku.k.p2;
1825
1826 p->ku.k.p1 = NULL;
1827 p->ku.k.p2 = NULL;
1828
1829 return compile_expr(form, env, p->ku.k.i1);
1830 }
1831
compile_expr(Scheme_Object * form,Scheme_Comp_Env * env,int app_position)1832 Scheme_Object *compile_expr(Scheme_Object *form, Scheme_Comp_Env *env, int app_position)
1833 {
1834 #ifdef DO_STACK_CHECK
1835 {
1836 # include "mzstkchk.h"
1837 {
1838 Scheme_Thread *p = scheme_current_thread;
1839
1840 p->ku.k.p1 = (void *)form;
1841 p->ku.k.p2 = (void *)env;
1842 p->ku.k.i1 = app_position;
1843
1844 return scheme_handle_stack_overflow(compile_expr_k);
1845 }
1846 }
1847 #endif
1848
1849 DO_CHECK_FOR_BREAK(scheme_current_thread, ;);
1850
1851 if (!SCHEME_STX_PAIRP(form)) {
1852 Scheme_Object *val = SCHEME_STX_SYM(form);
1853 if (SCHEME_SYMBOLP(val))
1854 return scheme_compile_lookup(form, env, (app_position ? SCHEME_APP_POS : 0));
1855 else if (SCHEME_NUMBERP(val)
1856 || SCHEME_CHAR_STRINGP(val)
1857 || SCHEME_BYTE_STRINGP(val)
1858 || SAME_OBJ(val, scheme_true)
1859 || SAME_OBJ(val, scheme_false))
1860 return val;
1861 else
1862 scheme_wrong_syntax("compile", form, NULL, "unrecognized form");
1863 } else {
1864 Scheme_Object *name = SCHEME_STX_CAR(form);
1865 if (SCHEME_STX_SYMBOLP(name)) {
1866 /* check for primitive expression forms */
1867 name = SCHEME_STX_SYM(name);
1868 if (SAME_OBJ(name, quote_symbol))
1869 return quote_compile(form, env);
1870 else if (SAME_OBJ(name, let_values_symbol))
1871 return let_values_compile(form, env);
1872 else if (SAME_OBJ(name, letrec_values_symbol))
1873 return letrec_values_compile(form, env);
1874 else if (SAME_OBJ(name, lambda_symbol))
1875 return lambda_compile(form, env);
1876 else if (SAME_OBJ(name, case_lambda_symbol))
1877 return case_lambda_compile(form, env);
1878 else if (SAME_OBJ(name, set_symbol))
1879 return set_compile(form, env);
1880 else if (SAME_OBJ(name, if_symbol))
1881 return if_compile(form, env);
1882 else if (SAME_OBJ(name, begin_symbol))
1883 return begin_compile(form, env);
1884 else if (SAME_OBJ(name, begin0_symbol))
1885 return begin0_compile(form, env);
1886 else if (SAME_OBJ(name, with_cont_mark_symbol))
1887 return with_cont_mark_compile(form, env);
1888 else if (SAME_OBJ(name, ref_symbol))
1889 return ref_compile(form, env);
1890 else if (SAME_OBJ(name, ref_symbol))
1891 return ref_compile(form, env);
1892 }
1893 }
1894
1895 return compile_app(form, env);
1896 }
1897
1898 /*========================================================================*/
1899 /* linklet compilation */
1900 /*========================================================================*/
1901
is_define_values(Scheme_Object * form)1902 static int is_define_values(Scheme_Object *form)
1903 {
1904 Scheme_Object *rest;
1905
1906 if (!SCHEME_STX_PAIRP(form))
1907 return 0;
1908
1909 rest = SCHEME_STX_CAR(form);
1910 if (!SAME_OBJ(SCHEME_STX_SYM(rest), define_values_symbol))
1911 return 0;
1912
1913 return 1;
1914 }
1915
define_parse(Scheme_Object * form,Scheme_Object ** _vars,Scheme_Object ** _val,Scheme_Comp_Env ** _env,DupCheckRecord * r,int * _extra_vars_pos,Scheme_Hash_Tree ** _source_names)1916 static Scheme_Object *define_parse(Scheme_Object *form,
1917 Scheme_Object **_vars, Scheme_Object **_val,
1918 Scheme_Comp_Env **_env,
1919 DupCheckRecord *r,
1920 int *_extra_vars_pos,
1921 Scheme_Hash_Tree **_source_names)
1922 {
1923 Scheme_Object *vars, *rest, *name, *src_name, *v, *extra_vars = scheme_null;
1924 Scheme_Comp_Env *env;
1925 Scheme_Hash_Tree *source_names = *_source_names;
1926 int len;
1927
1928 len = check_form(form, form);
1929 if (len != 3)
1930 bad_form(form, len);
1931
1932 rest = SCHEME_STX_CDR(form);
1933 vars = SCHEME_STX_CAR(rest);
1934 rest = SCHEME_STX_CDR(rest);
1935 *_val = SCHEME_STX_CAR(rest);
1936
1937 *_vars = vars;
1938
1939 while (SCHEME_STX_PAIRP(vars)) {
1940 name = SCHEME_STX_CAR(vars);
1941 scheme_check_identifier(NULL, name, NULL, form);
1942
1943 src_name = extract_source_name(name, 0);
1944 if (!SAME_OBJ(src_name, SCHEME_STX_SYM(name)))
1945 source_names = scheme_hash_tree_set(source_names, SCHEME_STX_SYM(name), src_name);
1946
1947 vars = SCHEME_STX_CDR(vars);
1948
1949 scheme_dup_symbol_check(r, NULL, name, "binding", form);
1950
1951 v = scheme_compile_lookup(name, *_env, SCHEME_NULL_FOR_UNBOUND);
1952 if (v && (!SAME_TYPE(SCHEME_TYPE(v), scheme_ir_toplevel_type)
1953 || ((Scheme_IR_Toplevel *)v)->instance_pos != -1))
1954 scheme_wrong_syntax(NULL, name, form, "not a definable variable");
1955
1956 if (!v) {
1957 v = (Scheme_Object *)scheme_make_ir_toplevel(-1, *_extra_vars_pos, 0);
1958 env = scheme_extend_comp_env(*_env, name, v, 1, 0);
1959 *_env = env;
1960 extra_vars = scheme_make_pair(name, extra_vars);
1961 (*_extra_vars_pos)++;
1962 }
1963 }
1964
1965 if (!SCHEME_STX_NULLP(vars))
1966 scheme_wrong_syntax(NULL, vars, form, "bad variable list");
1967
1968 *_source_names = source_names;
1969
1970 return extra_vars;
1971 }
1972
check_import_export_clause(Scheme_Object * e,Scheme_Object * orig_form)1973 static void check_import_export_clause(Scheme_Object *e, Scheme_Object *orig_form)
1974 {
1975 if (SCHEME_STX_SYMBOLP(e))
1976 return;
1977
1978 if (SCHEME_STX_PAIRP(e)) {
1979 if (SCHEME_STX_SYMBOLP(SCHEME_STX_CAR(e))) {
1980 e = SCHEME_STX_CDR(e);
1981 if (SCHEME_STX_PAIRP(e)) {
1982 if (SCHEME_STX_SYMBOLP(SCHEME_STX_CAR(e))) {
1983 e = SCHEME_STX_CDR(e);
1984 if (SCHEME_STX_NULLP(e))
1985 return;
1986 }
1987 }
1988 }
1989 }
1990
1991 scheme_wrong_syntax(NULL, e, orig_form, "bad import/export clause");
1992 }
1993
extract_source_name(Scheme_Object * e,int no_default)1994 static Scheme_Object *extract_source_name(Scheme_Object *e, int no_default)
1995 {
1996 Scheme_Object *a;
1997
1998 a = scheme_stx_property(e, source_name_symbol, NULL);
1999 if (!a || !SCHEME_SYMBOLP(a)) {
2000 if (no_default)
2001 a = NULL;
2002 else
2003 a = SCHEME_STX_SYM(e);
2004 }
2005
2006 return a;
2007 }
2008
scheme_compile_linklet(Scheme_Object * form,int set_undef,Scheme_Object * import_keys)2009 Scheme_Linklet *scheme_compile_linklet(Scheme_Object *form, int set_undef, Scheme_Object *import_keys)
2010 {
2011 Scheme_Linklet *linklet;
2012 Scheme_Object *orig_form = form, *imports, *exports;
2013 Scheme_Object *defn_syms, *a, *e, *extra_vars, *vec, *v;
2014 Scheme_Object *import_syms, *import_symss, *bodies, *all_extra_vars;
2015 Scheme_Hash_Tree *source_names, *also_used_names;
2016 Scheme_IR_Toplevel *tl;
2017 int body_len, len, islen, i, j, extra_vars_pos;
2018 Scheme_Comp_Env *env, *d_env;
2019 DupCheckRecord r;
2020
2021 body_len = check_form(form, form);
2022 if (body_len < 3)
2023 bad_form(form, body_len);
2024
2025 linklet = MALLOC_ONE_TAGGED(Scheme_Linklet);
2026 linklet->so.type = scheme_linklet_type;
2027
2028 env = scheme_new_comp_env(linklet, set_undef ? COMP_ENV_ALLOW_SET_UNDEFINED : 0);
2029
2030 form = SCHEME_STX_CDR(form);
2031 imports = SCHEME_STX_CAR(form);
2032 form = SCHEME_STX_CDR(form);
2033 exports = SCHEME_STX_CAR(form);
2034 form = SCHEME_STX_CDR(form);
2035 body_len -= 3;
2036
2037 /* Parse imports, filling in `ilens` and `import_syms`, and also
2038 extending `env`. */
2039 islen = scheme_stx_proper_list_length(imports);
2040 if (islen < 0)
2041 scheme_wrong_syntax(NULL, imports, orig_form, IMPROPER_LIST_FORM);
2042
2043 if (import_keys && (SCHEME_VEC_SIZE(import_keys) != islen))
2044 scheme_contract_error("compile-linklet",
2045 "import count of linklet form does not match given number of import keys",
2046 "linklet", 1, linklet,
2047 "linklet form imports", 1, scheme_make_integer(islen),
2048 "given keys", 1, scheme_make_integer(SCHEME_VEC_SIZE(import_keys)),
2049 NULL);
2050
2051 import_symss = scheme_make_vector(islen, scheme_false);
2052
2053 for (i = 0; i < islen; i++, imports = SCHEME_STX_CDR(imports)) {
2054 a = SCHEME_STX_CAR(imports);
2055 len = scheme_stx_proper_list_length(a);
2056
2057 import_syms = scheme_make_vector(len, NULL);
2058 SCHEME_VEC_ELS(import_symss)[i] = import_syms;
2059
2060 for (j = 0; j < len; j++, a = SCHEME_STX_CDR(a)) {
2061 e = SCHEME_STX_CAR(a);
2062 check_import_export_clause(e, orig_form);
2063 if (SCHEME_STX_SYMBOLP(e)) {
2064 SCHEME_VEC_ELS(import_syms)[j] = SCHEME_STX_SYM(e);
2065 } else {
2066 SCHEME_VEC_ELS(import_syms)[j] = SCHEME_STX_SYM(SCHEME_STX_CAR(e));
2067 e = SCHEME_STX_CADR(e);
2068 }
2069 tl = scheme_make_ir_toplevel(i, j, SCHEME_TOPLEVEL_READY);
2070 env = scheme_extend_comp_env(env, e, (Scheme_Object *)tl, 1, 1);
2071 if (!env)
2072 scheme_wrong_syntax("linklet", e, NULL, "duplicate import");
2073 }
2074
2075 linklet->num_total_imports += len;
2076 }
2077
2078 /* Parse exports, filling in `defn_syms` and extending `env`. */
2079 len = scheme_stx_proper_list_length(exports);
2080 if (len < 0)
2081 scheme_wrong_syntax(NULL, exports, orig_form, IMPROPER_LIST_FORM);
2082
2083 linklet->num_exports = len;
2084
2085 scheme_begin_dup_symbol_check(&r);
2086
2087 defn_syms = scheme_make_vector(len, NULL);
2088 source_names = scheme_make_hash_tree(0);
2089 also_used_names = scheme_make_hash_tree(0);
2090
2091 for (j = 0; j < len; j++, exports = SCHEME_STX_CDR(exports)) {
2092 e = SCHEME_STX_CAR(exports);
2093 check_import_export_clause(e, orig_form);
2094 if (SCHEME_STX_SYMBOLP(e)) {
2095 a = SCHEME_STX_SYM(e);
2096 } else {
2097 a = SCHEME_STX_SYM(SCHEME_STX_CADR(e));
2098 e = SCHEME_STX_CAR(e);
2099 }
2100 /* The export name is used as the variable name. Note that the
2101 export name at the `linklet` level will correspond to the
2102 definition name at the `module` level. */
2103 SCHEME_VEC_ELS(defn_syms)[j] = a;
2104 if (scheme_hash_tree_get(source_names, a) || scheme_hash_tree_get(also_used_names, a)) {
2105 scheme_wrong_syntax("linklet", a, NULL, "duplicate export");
2106 }
2107 /* Alternative source name supplied? */
2108 a = extract_source_name(e, 1);
2109 if (a) {
2110 if (!SAME_OBJ(a, SCHEME_VEC_ELS(defn_syms)[j]))
2111 source_names = scheme_hash_tree_set(source_names, SCHEME_VEC_ELS(defn_syms)[j], a);
2112 else
2113 also_used_names = scheme_hash_tree_set(also_used_names, SCHEME_VEC_ELS(defn_syms)[j], scheme_true);
2114 } else {
2115 /* Otherwise, use the export name (not the defined name) as the public name;
2116 it matches the variable name */
2117 also_used_names = scheme_hash_tree_set(also_used_names, SCHEME_VEC_ELS(defn_syms)[j], scheme_true);
2118 }
2119 tl = scheme_make_ir_toplevel(-1, j, 0);
2120 env = scheme_extend_comp_env(env, e, (Scheme_Object *)tl, 1, 1);
2121 if (!env)
2122 scheme_wrong_syntax("linklet", e, NULL, "export duplicates import");
2123 }
2124
2125 /* Looks for `define-values` forms to detect variables that are defined but
2126 not exported */
2127 extra_vars_pos = len;
2128 all_extra_vars = scheme_null;
2129
2130 for (i = 0, a = form; i < body_len; i++, a = SCHEME_STX_CDR(a)) {
2131 e = SCHEME_STX_CAR(a);
2132 if (is_define_values(e)) {
2133 Scheme_Object *vars, *vals;
2134 extra_vars = define_parse(e, &vars, &vals, &env, &r, &extra_vars_pos, &source_names);
2135 if (extra_vars) {
2136 all_extra_vars = scheme_append(extra_vars, all_extra_vars);
2137 }
2138 }
2139 }
2140
2141 if (extra_vars_pos) {
2142 a = defn_syms;
2143 defn_syms = scheme_make_vector(extra_vars_pos, NULL);
2144 for (i = 0; i < len; i++) {
2145 SCHEME_VEC_ELS(defn_syms)[i] = SCHEME_VEC_ELS(a)[i];
2146 }
2147
2148 all_extra_vars = scheme_reverse(all_extra_vars);
2149 for (i = len; i < extra_vars_pos; i++, all_extra_vars = SCHEME_CDR(all_extra_vars)) {
2150 e = SCHEME_CAR(all_extra_vars);
2151 a = SCHEME_STX_SYM(e);
2152 if (scheme_hash_tree_get(source_names, a) || scheme_hash_tree_get(also_used_names, a)) {
2153 /* Internal name conflicts with an exported name --- which is allowed, but means
2154 that we need to pick a different name for the bucket */
2155 a = generate_defn_name(a, source_names, also_used_names, extra_vars_pos);
2156 }
2157 SCHEME_VEC_ELS(defn_syms)[i] = a;
2158 a = extract_source_name(e, 0);
2159 if (!SAME_OBJ(a, SCHEME_VEC_ELS(defn_syms)[i]))
2160 source_names = scheme_hash_tree_set(source_names, SCHEME_VEC_ELS(defn_syms)[i], a);
2161 else
2162 also_used_names = scheme_hash_tree_set(also_used_names, a, scheme_true);
2163 }
2164 }
2165
2166 /* Prepare linklet record */
2167
2168 linklet->importss = import_symss;
2169 linklet->defns = defn_syms;
2170 linklet->source_names = source_names;
2171
2172 /* Compile body forms */
2173 bodies = scheme_make_vector(body_len, scheme_false);
2174
2175 linklet->bodies = bodies;
2176
2177 for (i = 0; i < body_len; i++, form = SCHEME_STX_CDR(form)) {
2178 e = SCHEME_STX_CAR(form);
2179 if (is_define_values(e)) {
2180 a = SCHEME_STX_CADR(e);
2181 len = scheme_stx_proper_list_length(a);
2182 vec = scheme_make_vector(len+1, NULL);
2183
2184 if (len == 1)
2185 d_env = scheme_set_comp_env_name(env, SCHEME_STX_CAR(a));
2186 else
2187 d_env = env;
2188
2189 for (j = 0; j < len; j++, a = SCHEME_STX_CDR(a)) {
2190 v = scheme_compile_lookup(SCHEME_STX_CAR(a), env, 0);
2191 MZ_ASSERT(SAME_TYPE(SCHEME_TYPE(v), scheme_ir_toplevel_type));
2192 MZ_ASSERT(((Scheme_IR_Toplevel *)v)->instance_pos == -1);
2193 SCHEME_DEFN_VAR_(vec, j) = v;
2194 }
2195
2196 a = compile_expr(SCHEME_STX_CADR(SCHEME_STX_CDR(e)), d_env, 0);
2197 SCHEME_DEFN_RHS(vec) = a;
2198
2199 if (SCHEME_TRUEP(scheme_stx_property(e, compiler_inline_hint_symbol, NULL))) {
2200 /* mark compiler-inline hint: */
2201 SCHEME_SET_DEFN_ALWAYS_INLINE(vec);
2202 }
2203
2204 e = vec;
2205 e->type = scheme_define_values_type;
2206 } else {
2207 e = compile_expr(e, env, 0);
2208 }
2209
2210 SCHEME_VEC_ELS(bodies)[i] = e;
2211 }
2212
2213 return linklet;
2214 }
2215
generate_defn_name(Scheme_Object * base_sym,Scheme_Hash_Tree * used_names,Scheme_Hash_Tree * also_used_names,int search_start)2216 static Scheme_Object *generate_defn_name(Scheme_Object *base_sym,
2217 Scheme_Hash_Tree *used_names,
2218 Scheme_Hash_Tree *also_used_names,
2219 int search_start)
2220 {
2221 char buf[32];
2222 Scheme_Object *n;
2223
2224 while (1) {
2225 sprintf(buf, ".%d", search_start);
2226 n = scheme_intern_exact_parallel_symbol(buf, strlen(buf));
2227 n = scheme_symbol_append(base_sym, n);
2228 if (!scheme_hash_tree_get(used_names, n) && !scheme_hash_tree_get(also_used_names, n))
2229 return n;
2230 }
2231 }
2232
2233
2234 /**********************************************************************/
2235 /* precise GC */
2236 /**********************************************************************/
2237
2238 #ifdef MZ_PRECISE_GC
2239
2240 START_XFORM_SKIP;
2241
2242 #include "mzmark_compile.inc"
2243
register_traversers(void)2244 static void register_traversers(void)
2245 {
2246 GC_REG_TRAV(scheme_rt_ir_lambda_info, mark_ir_lambda_info);
2247 }
2248
2249 END_XFORM_SKIP;
2250
2251 #endif
2252