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