1
2/* For non-tail calls, the native context has already
3   incremented MZ_CONT_MARK_POS. Counter
4   scheme_do_eval()'s increment, because this
5   might be the continuation of a tail call. */
6
7/* The arguments in argv are in the runstack. If computation can go
8   back into native code, those arguments should not live past the
9   native-code call. The native code clears/reuses arguments itself if
10   they are on the stack, but there's a problem if a tail buffer leads
11   to new pushes onto the run stack. We handle this with code marked
12   [TC-SFS]. */
13
14/* This code is written in such a way that xform can
15   see that no GC cooperation is needed. */
16
17static MZ_INLINE Scheme_Object *PRIM_APPLY_NAME_FAST(Scheme_Object *rator,
18                                                     int argc,
19                                                     Scheme_Object **argv)
20{
21  GC_CAN_IGNORE Scheme_Object *v;
22  GC_CAN_IGNORE Scheme_Primitive_Proc *prim;
23  GC_CAN_IGNORE Scheme_Primitive_Closure_Proc *f;
24
25  prim = (Scheme_Primitive_Proc *)rator;
26
27  if (argc < prim->mina || (argc > prim->mu.maxa && prim->mina >= 0)) {
28    scheme_wrong_count_m(prim->name, prim->mina, prim->mu.maxa, argc, argv, 0);
29    return NULL; /* Shouldn't get here */
30  }
31
32  f = (Scheme_Primitive_Closure_Proc *)prim->prim_val;
33  v = f(argc, argv, (Scheme_Object *)prim);
34
35#if PRIM_CHECK_VALUE
36  if (v == SCHEME_TAIL_CALL_WAITING) {
37    int i;
38    for (i = 0; i < argc; i++) { argv[i] = NULL; } /* [TC-SFS]; see above */
39    v = scheme_force_value_same_mark(v);
40  }
41#endif
42
43#if PRIM_CHECK_MULTI
44  if (v == SCHEME_MULTIPLE_VALUES) {
45    scheme_wrong_return_arity(NULL, 1, scheme_multiple_count, scheme_multiple_array, NULL);
46    return NULL; /* Shouldn't get here */
47  }
48#endif
49
50  return v;
51}
52
53Scheme_Object *PRIM_APPLY_NAME(Scheme_Object *rator,
54                               int argc,
55                               Scheme_Object **argv)
56{
57  if (!SCHEME_INTP(rator)) {
58    Scheme_Type t;
59
60    t = _SCHEME_TYPE(rator);
61
62    if ((t == scheme_proc_chaperone_type)
63        && SCHEME_REDIRECTS_PROCEDUREP((((Scheme_Chaperone *)rator)->redirects))
64        && (SCHEME_CHAPERONE_FLAGS((Scheme_Chaperone *)rator) == SCHEME_PROC_CHAPERONE_CALL_DIRECT)) {
65      if (SCHEME_FALSEP(SCHEME_VEC_ELS(((Scheme_Chaperone *)rator)->redirects)[1])
66          || SCHEME_INT_VAL(SCHEME_VEC_ELS(((Scheme_Chaperone *)rator)->redirects)[1]) == argc) {
67        /* No redirection proc, i.e, chaperone is just for
68	   properties or produced by unsafe-chaperone-procedure result -- and in the
69           latter case, the arity is right. */
70        GC_CAN_IGNORE Scheme_Thread *p = scheme_current_thread;
71        if (SCHEME_IMMUTABLEP(((Scheme_Chaperone *)rator)->redirects) && !p->self_for_proc_chaperone)
72          p->self_for_proc_chaperone = rator;
73        rator = SCHEME_VEC_ELS(((Scheme_Chaperone *)rator)->redirects)[0];
74        t = _SCHEME_TYPE(rator);
75      } else
76        return scheme_apply_chaperone(rator, argc, argv, NULL, PRIM_CHECK_MULTI | (PRIM_CHECK_VALUE << 1));
77    }
78
79    if (t == scheme_prim_type) {
80      return PRIM_APPLY_NAME_FAST(rator, argc, argv);
81    }
82  }
83
84#if PRIM_CHECK_MULTI
85  {
86    GC_CAN_IGNORE Scheme_Object *v;
87    MZ_CONT_MARK_POS -= 2;
88
89
90    v = _scheme_apply(rator, argc, argv);
91    MZ_CONT_MARK_POS += 2;
92    return v;
93  }
94#else
95# if PRIM_CHECK_VALUE
96  {
97
98    GC_CAN_IGNORE Scheme_Object *v;
99    MZ_CONT_MARK_POS -= 2;
100    v = _scheme_apply_multi(rator, argc, argv);
101    MZ_CONT_MARK_POS += 2;
102    return v;
103  }
104# else
105
106  return _scheme_tail_apply(rator, argc, argv);
107# endif
108#endif
109}
110
111#undef PRIM_CHECK_VALUE
112#undef PRIM_CHECK_MULTI
113#undef PRIM_APPLY_NAME
114#undef PRIM_APPLY_NAME_FAST
115