Back to index

plt-scheme  4.2.1
schapp.inc
Go to the documentation of this file.
00001 
00002   MZ_MARK_STACK_TYPE old_cont_mark_stack;
00003   GC_CAN_IGNORE Scheme_Object *v;
00004   GC_CAN_IGNORE Scheme_Primitive_Closure *prim;
00005   GC_CAN_IGNORE Scheme_Thread *p = scheme_current_thread;
00006   GC_CAN_IGNORE Scheme_Primitive_Closure_Proc *f;
00007 
00008 #if !PRIM_NO_STACK_CHECK
00009 # ifdef DO_STACK_CHECK
00010 #  define SCHEME_CURRENT_PROCESS p
00011 #  ifdef MZ_REAL_THREADS
00012 #   define SCHEME_STACK_BOUNDARY ((unsigned long)p->stack_end)
00013 #  endif
00014 #  include "mzstkchk.h"
00015   {
00016 #  ifndef ERROR_ON_OVERFLOW
00017     GC_CAN_IGNORE void *ra;
00018     if (argc) {
00019       int i;
00020       ra = (void *)MALLOC_N(Scheme_Object*, argc);
00021       for (i = argc; i--; ) {
00022        ((Scheme_Object **)ra)[i] = argv[i];
00023       }
00024     } else
00025       ra = NULL;
00026     p->ku.k.p1 = (void *)rator;
00027     p->ku.k.i1 = argc;
00028     p->ku.k.p2 = (void *)ra;
00029 #  endif
00030     return scheme_handle_stack_overflow(do_apply_known_k);
00031   }
00032 # endif
00033 
00034   DO_CHECK_FOR_BREAK(p, ;);
00035 #endif
00036 
00037   prim = (Scheme_Primitive_Closure *)rator;
00038 
00039 #if PRIM_CHECK_ARITY
00040   if (argc < prim->p.mina || (argc > prim->p.mu.maxa && prim->p.mina >= 0)) {
00041     scheme_wrong_count_m(prim->p.name, prim->p.mina, prim->p.mu.maxa, argc, argv,
00042                          prim->p.pp.flags & SCHEME_PRIM_IS_METHOD);
00043     return NULL; /* Shouldn't get here */
00044   }
00045 #endif
00046 
00047   MZ_CONT_MARK_POS++;
00048   old_cont_mark_stack = MZ_CONT_MARK_STACK;
00049 
00050   f = prim->p.prim_val;
00051   v = f(argc, argv, (Scheme_Object *)prim);
00052 
00053 #if !PRIM_NO_CHECK_VALUE
00054   v = _scheme_force_value(v);
00055 #endif
00056 
00057 #if PRIM_CHECK_MULTI
00058   if (v == SCHEME_MULTIPLE_VALUES) {
00059     scheme_wrong_return_arity(NULL, 1, scheme_multiple_count, scheme_multiple_array, NULL);
00060     return NULL; /* Shouldn't get here */
00061   }
00062 #endif
00063 
00064   --MZ_CONT_MARK_POS;
00065   MZ_CONT_MARK_STACK = old_cont_mark_stack;
00066 
00067   DEBUG_CHECK_TYPE(v);
00068 
00069   return v;
00070 
00071 #undef PRIM_NO_STACK_CHECK
00072 #undef PRIM_NO_CHECK_VALUE
00073 #undef PRIM_CHECK_ARITY
00074 #undef PRIM_CHECK_MULTI