X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/ae7f13be4bda70a6bc4a8478ce043df1a752ee6e..ef7a71b768c583d795b5de6b0c49177e7dfb0dbf:/libguile/vectors.c diff --git a/libguile/vectors.c b/libguile/vectors.c index 920ead10e..5dab5454a 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -1,5 +1,5 @@ /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008, 2009, 2010, - * 2011, 2012 Free Software Foundation, Inc. + * 2011, 2012, 2014 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -35,7 +35,6 @@ #include "libguile/strings.h" #include "libguile/srfi-13.h" #include "libguile/dynwind.h" -#include "libguile/deprecation.h" #include "libguile/bdw-gc.h" @@ -47,14 +46,7 @@ int scm_is_vector (SCM obj) { - if (SCM_I_IS_VECTOR (obj)) - return 1; - if (SCM_I_ARRAYP (obj) && SCM_I_ARRAY_NDIM (obj) == 1) - { - SCM v = SCM_I_ARRAY_V (obj); - return SCM_I_IS_VECTOR (v); - } - return 0; + return SCM_I_IS_VECTOR (obj); } int @@ -107,30 +99,24 @@ SCM_DEFINE (scm_vector_p, "vector?", 1, 0, 0, } #undef FUNC_NAME -SCM_GPROC (s_vector_length, "vector-length", 1, 0, 0, scm_vector_length, g_vector_length); -/* Returns the number of elements in @var{vector} as an exact integer. */ -SCM -scm_vector_length (SCM v) +SCM_DEFINE (scm_vector_length, "vector-length", 1, 0, 0, + (SCM v), + "Returns the number of elements in @var{vector} as an exact integer.") +#define FUNC_NAME s_scm_vector_length { - if (SCM_I_IS_VECTOR (v)) - return scm_from_size_t (SCM_I_VECTOR_LENGTH (v)); - else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1) - { - scm_t_array_dim *dim = SCM_I_ARRAY_DIMS (v); - return scm_from_size_t (dim->ubnd - dim->lbnd + 1); - } - else - return scm_wta_dispatch_1 (g_vector_length, v, 1, "vector-length"); + return scm_from_size_t (scm_c_vector_length (v)); } +#undef FUNC_NAME size_t scm_c_vector_length (SCM v) +#define FUNC_NAME s_scm_vector_length { - if (SCM_I_IS_VECTOR (v)) - return SCM_I_VECTOR_LENGTH (v); - else - return scm_to_size_t (scm_vector_length (v)); + SCM_VALIDATE_VECTOR (1, v); + + return SCM_I_VECTOR_LENGTH (v); } +#undef FUNC_NAME SCM_REGISTER_PROC (s_list_to_vector, "list->vector", 1, 0, 0, scm_vector); /* @@ -175,122 +161,68 @@ SCM_DEFINE (scm_vector, "vector", 0, 0, 1, } #undef FUNC_NAME -SCM_GPROC (s_vector_ref, "vector-ref", 2, 0, 0, scm_vector_ref, g_vector_ref); - -/* - "@var{k} must be a valid index of @var{vector}.\n" - "@samp{Vector-ref} returns the contents of element @var{k} of\n" - "@var{vector}.\n\n" - "@lisp\n" - "(vector-ref '#(1 1 2 3 5 8 13 21) 5) @result{} 8\n" - "(vector-ref '#(1 1 2 3 5 8 13 21)\n" - " (let ((i (round (* 2 (acos -1)))))\n" - " (if (inexact? i)\n" - " (inexact->exact i)\n" - " i))) @result{} 13\n" - "@end lisp" -*/ - -SCM -scm_vector_ref (SCM v, SCM k) -#define FUNC_NAME s_vector_ref +SCM_DEFINE (scm_vector_ref, "vector-ref", 2, 0, 0, + (SCM vector, SCM k), + "@var{k} must be a valid index of @var{vector}.\n" + "@samp{Vector-ref} returns the contents of element @var{k} of\n" + "@var{vector}.\n\n" + "@lisp\n" + "(vector-ref '#(1 1 2 3 5 8 13 21) 5) @result{} 8\n" + "(vector-ref '#(1 1 2 3 5 8 13 21)\n" + " (let ((i (round (* 2 (acos -1)))))\n" + " (if (inexact? i)\n" + " (inexact->exact i)\n" + " i))) @result{} 13\n" + "@end lisp") +#define FUNC_NAME s_scm_vector_ref { - return scm_c_vector_ref (v, scm_to_size_t (k)); + return scm_c_vector_ref (vector, scm_to_size_t (k)); } #undef FUNC_NAME SCM scm_c_vector_ref (SCM v, size_t k) +#define FUNC_NAME s_scm_vector_ref { - if (SCM_I_IS_NONWEAK_VECTOR (v)) - { - if (k >= SCM_I_VECTOR_LENGTH (v)) - scm_out_of_range (NULL, scm_from_size_t (k)); - return SCM_SIMPLE_VECTOR_REF (v, k); - } - else if (SCM_I_WVECTP (v)) - return scm_c_weak_vector_ref (v, k); - else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1) - { - scm_t_array_dim *dim = SCM_I_ARRAY_DIMS (v); - SCM vv = SCM_I_ARRAY_V (v); - - k = SCM_I_ARRAY_BASE (v) + k*dim->inc; - if (k >= dim->ubnd - dim->lbnd + 1) - scm_out_of_range (NULL, scm_from_size_t (k)); - - if (SCM_I_IS_NONWEAK_VECTOR (vv)) - return SCM_SIMPLE_VECTOR_REF (vv, k); - else if (SCM_I_WVECTP (vv)) - return scm_c_weak_vector_ref (vv, k); - else - scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector"); - } - else - return scm_wta_dispatch_2 (g_vector_ref, v, scm_from_size_t (k), 2, - "vector-ref"); -} + SCM_VALIDATE_VECTOR (1, v); -SCM_GPROC (s_vector_set_x, "vector-set!", 3, 0, 0, scm_vector_set_x, g_vector_set_x); - -/* "@var{k} must be a valid index of @var{vector}.\n" - "@code{Vector-set!} stores @var{obj} in element @var{k} of @var{vector}.\n" - "The value returned by @samp{vector-set!} is unspecified.\n" - "@lisp\n" - "(let ((vec (vector 0 '(2 2 2 2) "Anna")))\n" - " (vector-set! vec 1 '("Sue" "Sue"))\n" - " vec) @result{} #(0 ("Sue" "Sue") "Anna")\n" - "(vector-set! '#(0 1 2) 1 "doe") @result{} @emph{error} ; constant vector\n" - "@end lisp" -*/ + if (k >= SCM_I_VECTOR_LENGTH (v)) + scm_out_of_range (NULL, scm_from_size_t (k)); -SCM -scm_vector_set_x (SCM v, SCM k, SCM obj) -#define FUNC_NAME s_vector_set_x + return SCM_SIMPLE_VECTOR_REF (v, k); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vector_set_x, "vector-set!", 3, 0, 0, + (SCM vector, SCM k, SCM obj), + "@var{k} must be a valid index of @var{vector}.\n" + "@code{Vector-set!} stores @var{obj} in element @var{k} of @var{vector}.\n" + "The value returned by @samp{vector-set!} is unspecified.\n" + "@lisp\n" + "(let ((vec (vector 0 '(2 2 2 2) \"Anna\")))\n" + " (vector-set! vec 1 '(\"Sue\" \"Sue\"))\n" + " vec) @result{} #(0 (\"Sue\" \"Sue\") \"Anna\")\n" + "(vector-set! '#(0 1 2) 1 \"doe\") @result{} @emph{error} ; constant vector\n" + "@end lisp") +#define FUNC_NAME s_scm_vector_set_x { - scm_c_vector_set_x (v, scm_to_size_t (k), obj); + scm_c_vector_set_x (vector, scm_to_size_t (k), obj); return SCM_UNSPECIFIED; } #undef FUNC_NAME void scm_c_vector_set_x (SCM v, size_t k, SCM obj) +#define FUNC_NAME s_scm_vector_set_x { - if (SCM_I_IS_NONWEAK_VECTOR (v)) - { - if (k >= SCM_I_VECTOR_LENGTH (v)) - scm_out_of_range (NULL, scm_from_size_t (k)); - SCM_SIMPLE_VECTOR_SET (v, k, obj); - } - else if (SCM_I_WVECTP (v)) - scm_c_weak_vector_set_x (v, k, obj); - else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1) - { - scm_t_array_dim *dim = SCM_I_ARRAY_DIMS (v); - SCM vv = SCM_I_ARRAY_V (v); - - k = SCM_I_ARRAY_BASE (v) + k*dim->inc; - if (k >= dim->ubnd - dim->lbnd + 1) - scm_out_of_range (NULL, scm_from_size_t (k)); - - if (SCM_I_IS_NONWEAK_VECTOR (vv)) - SCM_SIMPLE_VECTOR_SET (vv, k, obj); - else if (SCM_I_WVECTP (vv)) - scm_c_weak_vector_set_x (vv, k, obj); - else - scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector"); - } - else - { - if (SCM_UNPACK (g_vector_set_x)) - scm_wta_dispatch_n (g_vector_set_x, - scm_list_3 (v, scm_from_size_t (k), obj), - 0, - "vector-set!"); - else - scm_wrong_type_arg_msg (NULL, 0, v, "vector"); - } + SCM_VALIDATE_VECTOR (1, v); + + if (k >= SCM_I_VECTOR_LENGTH (v)) + scm_out_of_range (NULL, scm_from_size_t (k)); + + SCM_SIMPLE_VECTOR_SET (v, k, obj); } +#undef FUNC_NAME SCM_DEFINE (scm_make_vector, "make-vector", 1, 1, 0, (SCM k, SCM fill), @@ -500,40 +432,6 @@ SCM_DEFINE (scm_vector_move_right_x, "vector-move-right!", 5, 0, 0, #undef FUNC_NAME -static SCM -vector_handle_ref (scm_t_array_handle *h, size_t idx) -{ - if (idx > h->dims[0].ubnd) - scm_out_of_range ("vector-handle-ref", scm_from_size_t (idx)); - return ((SCM*)h->elements)[idx]; -} - -static void -vector_handle_set (scm_t_array_handle *h, size_t idx, SCM val) -{ - if (idx > h->dims[0].ubnd) - scm_out_of_range ("vector-handle-set!", scm_from_size_t (idx)); - ((SCM*)h->writable_elements)[idx] = val; -} - -static void -vector_get_handle (SCM v, scm_t_array_handle *h) -{ - h->array = v; - h->ndims = 1; - h->dims = &h->dim0; - h->dim0.lbnd = 0; - h->dim0.ubnd = SCM_I_VECTOR_LENGTH (v) - 1; - h->dim0.inc = 1; - h->element_type = SCM_ARRAY_ELEMENT_TYPE_SCM; - h->elements = h->writable_elements = SCM_I_VECTOR_WELTS (v); -} - -/* the & ~2 allows catching scm_tc7_wvect as well. needs changing if you change - tags.h. */ -SCM_ARRAY_IMPLEMENTATION (scm_tc7_vector, 0x7f & ~2, - vector_handle_ref, vector_handle_set, - vector_get_handle) SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_SCM, scm_make_vector)