Back to index

plt-scheme  4.2.1
schmap.inc
Go to the documentation of this file.
00001 
00002 /* common code for `map', `for-each', `andmap' and `ormap' */
00003 
00004 /*
00005  DO_MAP = C function name
00006  MAP_NAME = Scheme function name as string
00007  MAP_MODE => map
00008  FOR_EACH_MODE => for-each
00009  AND_MODE => and mode
00010  OR_MODE => or mode
00011 */
00012 
00013 static Scheme_Object *
00014 DO_MAP(int argc, Scheme_Object *argv[])
00015 {
00016 # define NUM_QUICK_ARGS 3
00017 # define NUM_QUICK_RES  5
00018   int i, size = 0, l, pos;
00019   Scheme_Object *quick1[NUM_QUICK_ARGS], *quick2[NUM_QUICK_ARGS];
00020   Scheme_Object **working, **args;
00021 # ifdef MAP_MODE
00022   Scheme_Object *quick3[NUM_QUICK_RES], **resarray;
00023 # endif
00024 # ifndef FOR_EACH_MODE
00025   Scheme_Object *v;
00026 # endif
00027   int cc;
00028 
00029   if (!SCHEME_PROCP(argv[0]))
00030     scheme_wrong_type(MAP_NAME, "procedure", 0, argc, argv);
00031 
00032   for (i = 1; i < argc; i++) {
00033     l = scheme_proper_list_length(argv[i]);
00034     
00035     if (l < 0)
00036       scheme_wrong_type(MAP_NAME, "proper list", i, argc, argv);
00037     
00038     if (i == 1)
00039       size = l;
00040     else if (size != l) {
00041       char *argstr;
00042       long alen;
00043       
00044       argstr = scheme_make_args_string("", -1, argc, argv, &alen);
00045       
00046       scheme_raise_exn(MZEXN_FAIL_CONTRACT,
00047                        "%s: all lists must have same size%t",
00048                        MAP_NAME, argstr, alen);
00049       return NULL;
00050     }
00051   }
00052 
00053   if (SCHEME_FALSEP(scheme_get_or_check_arity(argv[0], argc - 1))) {
00054     char *s;
00055     long aelen;
00056 
00057     s = scheme_make_arity_expect_string(argv[0], argc - 1, NULL, &aelen);
00058 
00059     scheme_raise_exn(MZEXN_FAIL_CONTRACT,
00060                    "%s: arity mismatch for %t", MAP_NAME,
00061                    s, aelen);
00062     return NULL;
00063   }
00064 
00065   if (argc <= (NUM_QUICK_ARGS + 1)) {
00066     args = quick1;
00067     working = quick2;
00068   } else {
00069     args = MALLOC_N(Scheme_Object *, argc - 1);
00070     working = MALLOC_N(Scheme_Object *, argc - 1);
00071   }
00072 
00073 #ifdef MAP_MODE
00074   if (size <= NUM_QUICK_RES)
00075     resarray = quick3;
00076   else
00077     resarray = MALLOC_N(Scheme_Object *, size);
00078 #endif
00079 
00080   /* Copy argc into working array */
00081   for (i = 1; i < argc; i++) {
00082     working[i-1] = argv[i];
00083   }
00084 
00085   --argc;
00086 
00087   pos = 0;
00088   while (pos < size) {
00089     /* collect args to apply */
00090     for (i = 0; i < argc ; i++) {
00091 #if 0
00092       /* No longer needed: */
00093       if (!SCHEME_PAIRP(working[i])) {
00094        /* There was a mutation! */
00095        scheme_raise_exn(MZEXN_FAIL_CONTRACT,
00096                       "%s: argument list mutated",
00097                       MAP_NAME);
00098        return NULL;
00099       }
00100 #endif
00101       args[i] = SCHEME_CAR(working[i]);
00102       working[i] = SCHEME_CDR(working[i]);
00103     }
00104 
00105     cc = scheme_cont_capture_count;
00106 
00107 #ifdef MAP_MODE
00108     v = _scheme_apply(argv[0], argc, args);
00109 #else
00110 # ifdef FOR_EACH_MODE
00111     _scheme_apply_multi(argv[0], argc, args);
00112 # else
00113     if (pos + 1 == size) {
00114       return _scheme_tail_apply(argv[0], argc, args);
00115     } else {
00116       v = _scheme_apply(argv[0], argc, args);
00117     }
00118 # endif
00119 #endif
00120 
00121     if (cc != scheme_cont_capture_count) {
00122       /* Copy arrays to avoid messing with other continuations */
00123 #ifdef MAP_MODE
00124       if (size > NUM_QUICK_RES) {
00125        Scheme_Object **naya;
00126        naya = MALLOC_N(Scheme_Object *, size);
00127        memcpy(naya, resarray, pos * sizeof(Scheme_Object *));
00128        resarray = naya;
00129       }
00130 #endif
00131       if ((argc > NUM_QUICK_ARGS) && (pos + 1 < size)) {
00132        Scheme_Object **naya;
00133        args = MALLOC_N(Scheme_Object *, argc);
00134        naya = MALLOC_N(Scheme_Object *, argc);
00135        memcpy(naya, working, argc * sizeof(Scheme_Object *));
00136        working = naya;
00137       }
00138     }
00139 
00140 #ifdef MAP_MODE
00141     resarray[pos] = v;
00142 #endif
00143 #ifdef AND_MODE
00144     if (SCHEME_FALSEP(v))
00145       return scheme_false;
00146 #endif
00147 #ifdef OR_MODE
00148     if (SCHEME_TRUEP(v))
00149       return v;
00150 #endif
00151     pos++;
00152   }
00153 
00154 #ifdef MAP_MODE
00155   return scheme_build_list(size, resarray);
00156 #endif
00157 #ifdef FOR_EACH_MODE
00158   return scheme_void;
00159 #endif
00160 #ifdef AND_MODE
00161   return scheme_true;
00162 #endif
00163 #ifdef OR_MODE
00164   return scheme_false;
00165 #endif
00166 }