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