Back to index

plt-scheme  4.2.1
schnapp.inc
Go to the documentation of this file.
00001 /* For non-tail calls, the native context has already
00002    incremented MZ_CONT_MARK_POS. Counter
00003    scheme_do_eval()'s increment, because this
00004    might be the continuation of a tail call. */
00005 
00006 /* The arguments in argv are in the runstack. If computation can go
00007    back into native code, those arguments should not live past the
00008    native-code call. The native code clears/reuses arguments itself if
00009    they are on the stack, but there's a problem if a tail buffer leads
00010    to new pushes onto the run stack. We handle this with code marked
00011    [TC-SFS]. */
00012 
00013 /* This code is written in such a way that xform can
00014    see that no GC cooperation is needed. */
00015 
00016 static MZ_INLINE Scheme_Object *PRIM_APPLY_NAME_FAST(Scheme_Object *rator,
00017                                                      int argc,
00018                                                      Scheme_Object **argv)
00019 {
00020   GC_CAN_IGNORE Scheme_Object *v;
00021   GC_CAN_IGNORE Scheme_Primitive_Proc *prim;
00022   GC_CAN_IGNORE Scheme_Primitive_Closure_Proc *f;
00023   
00024   prim = (Scheme_Primitive_Proc *)rator;
00025   
00026   if (argc < prim->mina || (argc > prim->mu.maxa && prim->mina >= 0)) {
00027     scheme_wrong_count_m(prim->name, prim->mina, prim->mu.maxa, argc, argv,
00028                          prim->pp.flags & SCHEME_PRIM_IS_METHOD);
00029     return NULL; /* Shouldn't get here */
00030   }
00031   
00032   f = (Scheme_Primitive_Closure_Proc *)prim->prim_val;
00033   v = f(argc, argv, (Scheme_Object *)prim);
00034   
00035 #if PRIM_CHECK_VALUE
00036   if (v == SCHEME_TAIL_CALL_WAITING) {
00037     int i;
00038     for (i = 0; i < argc; i++) { argv[i] = NULL; } /* [TC-SFS]; see above */
00039     v = scheme_force_value_same_mark(v);
00040   }
00041 #endif
00042   
00043 #if PRIM_CHECK_MULTI
00044   if (v == SCHEME_MULTIPLE_VALUES) {
00045     scheme_wrong_return_arity(NULL, 1, scheme_multiple_count, scheme_multiple_array, NULL);
00046     return NULL; /* Shouldn't get here */
00047   }
00048 #endif
00049   
00050   return v;
00051 }
00052 
00053 Scheme_Object *PRIM_APPLY_NAME(Scheme_Object *rator,
00054                                int argc,
00055                                Scheme_Object **argv)
00056 {
00057   if (!SCHEME_INTP(rator)) {
00058     Scheme_Type t;
00059 
00060     t = _SCHEME_TYPE(rator);
00061 
00062     if (t == scheme_prim_type) {
00063       return PRIM_APPLY_NAME_FAST(rator, argc, argv);
00064     }
00065   }
00066 
00067 #if PRIM_CHECK_MULTI
00068   {
00069     GC_CAN_IGNORE Scheme_Object *v;
00070     MZ_CONT_MARK_POS -= 2;
00071     v = _scheme_apply(rator, argc, argv);
00072     MZ_CONT_MARK_POS += 2;
00073     return v;
00074   }
00075 #else
00076 # if PRIM_CHECK_VALUE
00077   {
00078     GC_CAN_IGNORE Scheme_Object *v;
00079     MZ_CONT_MARK_POS -= 2;
00080     v = _scheme_apply_multi(rator, argc, argv);
00081     MZ_CONT_MARK_POS += 2;
00082     return v;
00083   }
00084 # else
00085   return _scheme_tail_apply(rator, argc, argv);
00086 # endif
00087 #endif
00088 }
00089 
00090 #undef PRIM_CHECK_VALUE
00091 #undef PRIM_CHECK_MULTI
00092 #undef PRIM_APPLY_NAME
00093 #undef PRIM_APPLY_NAME_FAST