Back to index

plt-scheme  4.2.1
vector.c
Go to the documentation of this file.
00001 /*
00002   MzScheme
00003   Copyright (c) 2004-2009 PLT Scheme Inc.
00004   Copyright (c) 1995-2001 Matthew Flatt
00005 
00006     This library is free software; you can redistribute it and/or
00007     modify it under the terms of the GNU Library General Public
00008     License as published by the Free Software Foundation; either
00009     version 2 of the License, or (at your option) any later version.
00010 
00011     This library is distributed in the hope that it will be useful,
00012     but WITHOUT ANY WARRANTY; without even the implied warranty of
00013     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
00014     Library General Public License for more details.
00015 
00016     You should have received a copy of the GNU Library General Public
00017     License along with this library; if not, write to the Free
00018     Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
00019     Boston, MA 02110-1301 USA.
00020 
00021   libscheme
00022   Copyright (c) 1994 Brent Benson
00023   All rights reserved.
00024 */
00025 
00026 #include "schpriv.h"
00027 
00028 /* globals */
00029 Scheme_Object *scheme_vector_proc;
00030 Scheme_Object *scheme_vector_immutable_proc;
00031 
00032 /* locals */
00033 static Scheme_Object *vector_p (int argc, Scheme_Object *argv[]);
00034 static Scheme_Object *make_vector (int argc, Scheme_Object *argv[]);
00035 static Scheme_Object *vector (int argc, Scheme_Object *argv[]);
00036 static Scheme_Object *vector_immutable (int argc, Scheme_Object *argv[]);
00037 static Scheme_Object *vector_length (int argc, Scheme_Object *argv[]);
00038 static Scheme_Object *vector_to_list (int argc, Scheme_Object *argv[]);
00039 static Scheme_Object *list_to_vector (int argc, Scheme_Object *argv[]);
00040 static Scheme_Object *vector_fill (int argc, Scheme_Object *argv[]);
00041 static Scheme_Object *vector_copy_bang(int argc, Scheme_Object *argv[]);
00042 static Scheme_Object *vector_to_immutable (int argc, Scheme_Object *argv[]);
00043 static Scheme_Object *vector_to_values (int argc, Scheme_Object *argv[]);
00044 
00045 void
00046 scheme_init_vector (Scheme_Env *env)
00047 {
00048   Scheme_Object *p;
00049 
00050   p = scheme_make_folding_prim(vector_p, "vector?", 1, 1, 1);
00051   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
00052   scheme_add_global_constant("vector?", p, env);
00053 
00054   scheme_add_global_constant("make-vector", 
00055                           scheme_make_immed_prim(make_vector, 
00056                                               "make-vector", 
00057                                               1, 2), 
00058                           env);
00059   
00060   REGISTER_SO(scheme_vector_proc);
00061   p = scheme_make_immed_prim(vector, "vector", 0, -1);
00062   scheme_vector_proc = p;
00063   SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED
00064                                 | SCHEME_PRIM_IS_BINARY_INLINED
00065                                 | SCHEME_PRIM_IS_NARY_INLINED);
00066   scheme_add_global_constant("vector", p, env);
00067 
00068   REGISTER_SO(scheme_vector_immutable_proc);
00069   p = scheme_make_immed_prim(vector_immutable, "vector-immutable", 0, -1);
00070   scheme_vector_immutable_proc = p;
00071   SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED
00072                                 | SCHEME_PRIM_IS_BINARY_INLINED
00073                                 | SCHEME_PRIM_IS_NARY_INLINED);
00074   scheme_add_global_constant("vector-immutable", p, env);
00075   
00076   p = scheme_make_folding_prim(vector_length, "vector-length", 1, 1, 1);
00077   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
00078   scheme_add_global_constant("vector-length", p, env);
00079 
00080   p = scheme_make_immed_prim(scheme_checked_vector_ref, 
00081                           "vector-ref", 
00082                           2, 2);
00083   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
00084   scheme_add_global_constant("vector-ref", p, env);
00085 
00086   p = scheme_make_immed_prim(scheme_checked_vector_set,
00087                           "vector-set!", 
00088                           3, 3);
00089   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_NARY_INLINED;
00090   scheme_add_global_constant("vector-set!", p, env);
00091 
00092   scheme_add_global_constant("vector->list", 
00093                           scheme_make_immed_prim(vector_to_list, 
00094                                               "vector->list", 
00095                                               1, 1), 
00096                           env);
00097   scheme_add_global_constant("list->vector", 
00098                           scheme_make_immed_prim(list_to_vector, 
00099                                               "list->vector", 
00100                                               1, 1), 
00101                           env);
00102   scheme_add_global_constant("vector-fill!", 
00103                           scheme_make_immed_prim(vector_fill, 
00104                                               "vector-fill!", 
00105                                               2, 2), 
00106                           env);
00107   scheme_add_global_constant("vector-copy!", 
00108                           scheme_make_immed_prim(vector_copy_bang, 
00109                                               "vector-copy!", 
00110                                               3, 5), 
00111                           env);
00112   scheme_add_global_constant("vector->immutable-vector", 
00113                           scheme_make_immed_prim(vector_to_immutable, 
00114                                               "vector->immutable-vector", 
00115                                               1, 1), 
00116                           env);
00117   scheme_add_global_constant("vector->values", 
00118                           scheme_make_prim_w_arity2(vector_to_values, 
00119                                                        "vector->values", 
00120                                                        1, 3,
00121                                                        0, -1), 
00122                           env);
00123 }
00124 
00125 Scheme_Object *
00126 scheme_make_vector (long size, Scheme_Object *fill)
00127 {
00128   Scheme_Object *vec;
00129   long i;
00130 
00131   if (size < 0) {
00132     vec = scheme_make_integer(size);
00133     scheme_wrong_type("make-vector", "non-negative exact integer", -1, 0, &vec);
00134   }
00135 
00136   if (size < 1024) {
00137     vec = (Scheme_Object *)scheme_malloc_tagged(sizeof(Scheme_Vector) 
00138                                           + (size - 1) * sizeof(Scheme_Object *));
00139   } else {
00140     vec = (Scheme_Object *)scheme_malloc_fail_ok(scheme_malloc_tagged,
00141                                            sizeof(Scheme_Vector) 
00142                                            + (size - 1) * sizeof(Scheme_Object *));
00143   }
00144 
00145   vec->type = scheme_vector_type;
00146   SCHEME_VEC_SIZE(vec) = size;
00147 
00148   if (fill) {
00149     for (i = 0; i < size; i++) {
00150       SCHEME_VEC_ELS(vec)[i] = fill;
00151     }
00152   }
00153 
00154   return vec;
00155 }
00156 
00157 /* locals */
00158 
00159 static Scheme_Object *
00160 vector_p (int argc, Scheme_Object *argv[])
00161 {
00162   return (SCHEME_VECTORP(argv[0]) ? scheme_true : scheme_false);
00163 }
00164 
00165 static Scheme_Object *
00166 make_vector (int argc, Scheme_Object *argv[])
00167 {
00168   Scheme_Object *vec, *fill;
00169   long len;
00170 
00171   len = scheme_extract_index("make-vector", 0, argc, argv, -1, 0);
00172 
00173   if (len == -1) {
00174     scheme_raise_out_of_memory("make-vector", "making vector of length %s",
00175                             scheme_make_provided_string(argv[0], 1, NULL));
00176   }
00177 
00178   if (argc == 2)
00179     fill = argv[1];
00180   else
00181     fill = scheme_make_integer(0);
00182 
00183   vec = scheme_make_vector(len, fill);
00184 
00185   return vec;
00186 }
00187 
00188 static Scheme_Object *
00189 vector (int argc, Scheme_Object *argv[])
00190 {
00191   Scheme_Object *vec;
00192   int i;
00193 
00194   vec = scheme_make_vector (argc, 0);
00195   for (i = 0; i < argc ; i++) {
00196     SCHEME_VEC_ELS(vec)[i] = argv[i];
00197   }
00198 
00199   return vec;
00200 }
00201 
00202 static Scheme_Object *
00203 vector_immutable (int argc, Scheme_Object *argv[])
00204 {
00205   Scheme_Object *vec;
00206 
00207   vec = vector(argc, argv);
00208   SCHEME_SET_IMMUTABLE(vec);
00209 
00210   return vec;
00211 }
00212 
00213 static Scheme_Object *
00214 vector_length (int argc, Scheme_Object *argv[])
00215 {
00216   if (!SCHEME_VECTORP(argv[0]))
00217     scheme_wrong_type("vector-length", "vector", 0, argc, argv);
00218 
00219   return scheme_make_integer(SCHEME_VEC_SIZE(argv[0]));
00220 }
00221 
00222 Scheme_Object *scheme_vector_length(Scheme_Object *v)
00223 {
00224   Scheme_Object *a[1];
00225   a[0] = v;
00226   return vector_length(1, a);
00227 }
00228 
00229 static Scheme_Object *
00230 bad_index(char *name, Scheme_Object *i, Scheme_Object *vec, int bottom)
00231 {
00232   int n = SCHEME_VEC_SIZE(vec) - 1;
00233 
00234   if (SCHEME_VEC_SIZE(vec)) {
00235     char *vstr;
00236     int vlen;
00237     vstr = scheme_make_provided_string(vec, 2, &vlen);
00238     scheme_raise_exn(MZEXN_FAIL_CONTRACT,
00239                    "%s: index %s out of range [%d, %d] for vector: %t",
00240                    name, 
00241                    scheme_make_provided_string(i, 2, NULL), 
00242                    bottom, n,
00243                    vstr, vlen);
00244   } else
00245     scheme_raise_exn(MZEXN_FAIL_CONTRACT,
00246                    "%s: bad index %s for empty vector",
00247                    name,
00248                    scheme_make_provided_string(i, 0, NULL));
00249   
00250   return NULL;
00251 }
00252 
00253 Scheme_Object *
00254 scheme_checked_vector_ref (int argc, Scheme_Object *argv[])
00255 {
00256   long i, len;
00257 
00258   if (!SCHEME_VECTORP(argv[0]))
00259     scheme_wrong_type("vector-ref", "vector", 0, argc, argv);
00260 
00261   len = SCHEME_VEC_SIZE(argv[0]);
00262 
00263   i = scheme_extract_index("vector-ref", 1, argc, argv, len, 0);
00264 
00265   if (i >= len)
00266     return bad_index("vector-ref", argv[1], argv[0], 0);
00267 
00268   return (SCHEME_VEC_ELS(argv[0]))[i];
00269 }
00270 
00271 Scheme_Object *
00272 scheme_checked_vector_set(int argc, Scheme_Object *argv[])
00273 {
00274   long i, len;
00275 
00276   if (!SCHEME_MUTABLE_VECTORP(argv[0]))
00277     scheme_wrong_type("vector-set!", "mutable vector", 0, argc, argv);
00278 
00279   len = SCHEME_VEC_SIZE(argv[0]);
00280 
00281   i = scheme_extract_index("vector-set!", 1, argc, argv, len, 0);
00282 
00283   if (i >= len)
00284     return bad_index("vector-set!", argv[1], argv[0], 0);
00285 
00286   (SCHEME_VEC_ELS(argv[0]))[i] = argv[2];
00287 
00288   return scheme_void;
00289 }
00290 
00291 static Scheme_Object *
00292 vector_to_list (int argc, Scheme_Object *argv[])
00293 {
00294   if (!SCHEME_VECTORP(argv[0]))
00295     scheme_wrong_type("vector->list", "vector", 0, argc, argv);
00296 
00297   return scheme_vector_to_list(argv[0]);
00298 }
00299 
00300 # define cons(car, cdr) scheme_make_pair(car, cdr)
00301 
00302 Scheme_Object *
00303 scheme_vector_to_list (Scheme_Object *vec)
00304 {
00305   int i;
00306   Scheme_Object *pair = scheme_null;
00307 
00308   i = SCHEME_VEC_SIZE(vec);
00309 
00310   if (i < 0xFFF) {
00311     for (; i--; ) {
00312       pair = cons(SCHEME_VEC_ELS(vec)[i], pair);
00313     }
00314   } else {
00315     for (; i--; ) {
00316       if (!(i & 0xFFF))
00317        SCHEME_USE_FUEL(0xFFF);
00318       pair = cons(SCHEME_VEC_ELS(vec)[i], pair);
00319     }
00320   }
00321 
00322   return pair;
00323 }
00324 
00325 static Scheme_Object *
00326 list_to_vector (int argc, Scheme_Object *argv[])
00327 {
00328   return scheme_list_to_vector(argv[0]);
00329 }
00330 
00331 Scheme_Object *
00332 scheme_list_to_vector (Scheme_Object *list)
00333 {
00334   long len, i;
00335   Scheme_Object *vec, *orig = list;
00336 
00337   len = scheme_proper_list_length(list);
00338   if (len < 0)
00339     scheme_wrong_type("list->vector", "proper list", -1, 0, &orig);
00340 
00341   vec = scheme_make_vector(len, NULL);
00342   for (i = 0; i < len; i++) {
00343     SCHEME_VEC_ELS(vec)[i] = SCHEME_CAR(list);
00344     list = SCHEME_CDR(list);
00345   }
00346 
00347   return vec;
00348 }
00349 
00350 static Scheme_Object *
00351 vector_fill (int argc, Scheme_Object *argv[])
00352 {
00353   int i, sz;
00354   Scheme_Object *v;
00355   
00356   if (!SCHEME_MUTABLE_VECTORP(argv[0]))
00357     scheme_wrong_type("vector-fill!", "mutable vector", 0, argc, argv);
00358 
00359   v = argv[1];
00360   sz = SCHEME_VEC_SIZE(argv[0]);
00361   for (i = 0; i < sz; i++) {
00362     SCHEME_VEC_ELS(argv[0])[i] = v;
00363   }
00364 
00365   return argv[0];
00366 }
00367 
00368 static Scheme_Object *vector_copy_bang(int argc, Scheme_Object *argv[])
00369 {
00370   Scheme_Object *s1, *s2;
00371   long istart, ifinish;
00372   long ostart, ofinish;
00373 
00374   s1 = argv[0];
00375   if (!SCHEME_MUTABLE_VECTORP(s1))
00376     scheme_wrong_type("vector-copy!", "mutable vector", 0, argc, argv);
00377 
00378   scheme_do_get_substring_indices("vector-copy!", s1, 
00379                                   argc, argv, 1, 5, 
00380                                   &ostart, &ofinish, SCHEME_VEC_SIZE(s1));
00381 
00382   s2 = argv[2];
00383   if (!SCHEME_VECTORP(s2))
00384     scheme_wrong_type("vector-copy!", "vector", 2, argc, argv);
00385 
00386   scheme_do_get_substring_indices("vector-copy!", s2, 
00387                                   argc, argv, 3, 4, 
00388                                   &istart, &ifinish, SCHEME_VEC_SIZE(s2));
00389 
00390   if ((ofinish - ostart) < (ifinish - istart)) {
00391     scheme_arg_mismatch("vector-copy!",
00392                      "not enough room in target vector: ",
00393                      argv[2]);
00394     return NULL;
00395   }
00396 
00397   memmove(SCHEME_VEC_ELS(s1) + ostart,
00398          SCHEME_VEC_ELS(s2) + istart,
00399          (ifinish - istart) * sizeof(Scheme_Object*));
00400   
00401   return scheme_void;
00402 }
00403 
00404 static Scheme_Object *vector_to_immutable (int argc, Scheme_Object *argv[])
00405 {
00406   Scheme_Object *vec, *ovec;
00407   long len, i;
00408 
00409   if (!SCHEME_VECTORP(argv[0]))
00410     scheme_wrong_type("vector->immutable-vector", "vector", 0, argc, argv);
00411 
00412   if (SCHEME_IMMUTABLEP(argv[0]))
00413     return argv[0];
00414 
00415   ovec = argv[0];
00416   len = SCHEME_VEC_SIZE(ovec);
00417 
00418   vec = scheme_make_vector(len, NULL);
00419   for (i = 0; i < len; i++) {
00420     SCHEME_VEC_ELS(vec)[i] = SCHEME_VEC_ELS(ovec)[i];
00421   }
00422   SCHEME_SET_IMMUTABLE(vec);
00423 
00424   return vec;  
00425 }
00426 
00427 static Scheme_Object *vector_to_values (int argc, Scheme_Object *argv[])
00428 {
00429   Scheme_Thread *p;
00430   Scheme_Object *vec, **a;
00431   long len, start, finish, i;
00432 
00433   vec = argv[0];
00434 
00435   if (!SCHEME_VECTORP(vec))
00436     scheme_wrong_type("vector->values", "vector", 0, argc, argv);
00437 
00438   len = SCHEME_VEC_SIZE(vec);
00439 
00440   if (argc > 1)
00441     start = scheme_extract_index("vector->values", 1, argc, argv, len + 1, 0);
00442   else
00443     start = 0;
00444   if (argc > 2)
00445     finish = scheme_extract_index("vector->values", 2, argc, argv, len + 1, 0);
00446   else
00447     finish = len;
00448 
00449   if (!(start <= len)) {
00450     bad_index("vector->values", argv[1], vec, 0);
00451   }
00452   if (!(finish >= start && finish <= len)) {
00453     bad_index("vector->values", argv[2], vec, start);
00454   }
00455 
00456   len = finish - start;
00457   if (len == 1)
00458     return SCHEME_VEC_ELS(vec)[start];
00459 
00460   p = scheme_current_thread;
00461   if (p->values_buffer && (p->values_buffer_size >= len))
00462     a = p->values_buffer;
00463   else {
00464     a = MALLOC_N(Scheme_Object *, len);
00465     p->values_buffer = a;
00466     p->values_buffer_size = len;
00467   }
00468 
00469   p->ku.multiple.array = a;
00470   p->ku.multiple.count = len;
00471 
00472   for (i = 0; i < len; i++) {
00473     a[i] = SCHEME_VEC_ELS(vec)[start + i];
00474   }
00475 
00476   return SCHEME_MULTIPLE_VALUES;
00477 }