diff --git a/src/c/array.d b/src/c/array.d index f97cd5fbc..bc67e1aa8 100644 --- a/src/c/array.d +++ b/src/c/array.d @@ -420,7 +420,7 @@ ecl_aset1(cl_object x, cl_index index, cl_object value) /* Internal function for making arrays of more than one dimension: - (si:make-pure-array dimension-list element-type adjustable + (si:make-pure-array element-type dimension-list adjustable displaced-to displaced-index-offset) */ cl_object @@ -550,6 +550,23 @@ si_make_vector(cl_object etype, cl_object dim, cl_object adj, @(return x); } +cl_object +si_adjust_vector(cl_object vector, cl_object new_dim) { + cl_object new_vector; + if (!ECL_ADJUSTABLE_ARRAY_P(vector)) { + FEerror("The vector is not adjustable.", 0); + } + new_vector = si_make_vector(ecl_elttype_to_symbol(ecl_array_elttype(vector)), + new_dim, + ECL_T, + ecl_make_fixnum(vector->vector.fillp), + ECL_NIL, + ECL_NIL); + ecl_copy_subarray(new_vector, 0, vector, 0, vector->vector.dim); + si_replace_array(vector, new_vector); + return vector; +} + cl_object * alloc_pointerfull_memory(cl_index l) { @@ -1187,7 +1204,7 @@ si_fill_pointer_set(cl_object a, cl_object fp) (si:replace-array old-array new-array). - Used in ADJUST-ARRAY. + Used in ADJUST-ARRAY and SI:ADJUST-VECTOR. */ cl_object si_replace_array(cl_object olda, cl_object newa) diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 92361f796..9d0df5019 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1148,6 +1148,7 @@ cl_symbols[] = { {SYS_ "UNQUOTE" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "UNQUOTE-NSPLICE" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "UNQUOTE-SPLICE" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, +{SYS_ "ADJUST-VECTOR" ECL_FUN("si_adjust_vector", si_adjust_vector, 2) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "ALLOCATE-RAW-INSTANCE" ECL_FUN("si_allocate_raw_instance", si_allocate_raw_instance, 3) ECL_VAR(SI_ORDINARY, OBJNULL)}, {EXT_ "ARGC" ECL_FUN("si_argc", si_argc, 0) ECL_VAR(EXT_ORDINARY, OBJNULL)}, {EXT_ "ARGV" ECL_FUN("si_argv", si_argv, 1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, diff --git a/src/cmp/proclamations.lsp b/src/cmp/proclamations.lsp index 15a8ccfb3..0224b5b88 100644 --- a/src/cmp/proclamations.lsp +++ b/src/cmp/proclamations.lsp @@ -874,6 +874,7 @@ ;; ECL extensions (proclamation si:make-pure-array (t t t t t t) array) (proclamation si:make-vector (t t t t t t) vector) +(proclamation si:adjust-vector (vector ext:array-index) vector) (proclamation si:aset (array t &rest t) t) (proclamation si:row-major-aset (array ext:array-index t) t) (proclamation si:svset (simple-vector ext:array-index t) t) diff --git a/src/doc/manual/standards/arrays.txi b/src/doc/manual/standards/arrays.txi index 184ce0e01..5fd4196ec 100644 --- a/src/doc/manual/standards/arrays.txi +++ b/src/doc/manual/standards/arrays.txi @@ -114,12 +114,18 @@ Creating array and vectors @cppdef ecl_alloc_simple_vector @cppdef si_make_vector @cppdef si_make_array +@cppdef si_adjust_vector @deftypefun cl_object ecl_alloc_simple_vector (cl_index length, cl_elttype element_type); @deftypefunx cl_object si_make_vector (cl_object element_type, cl_object length, cl_object adjustablep, cl_object fill_pointerp, cl_object displaced_to, cl_object displacement); @deftypefunx cl_object si_make_array (cl_object element_type, cl_object dimensions, cl_object adjustablep, cl_object fill_pointerp, cl_object displaced_to, cl_object displacement); +@deftypefunx cl_object si_adjust_vector (cl_object vector, cl_object length); @paragraph Description -The function @coderef{ecl_alloc_simple_vector} is the simplest constructor, creating a simple vector (i.e. non-adjustable and without a fill pointer), of the given size, preallocating the memory for the array data. The first argument, @emph{element_type}, is a C constant that represents a valid array element type (See @coderef{cl_elttype}). +The function @coderef{ecl_alloc_simple_vector} is the simplest +constructor, creating a simple vector (i.e. non-adjustable and without +a fill pointer), of the given size, preallocating the memory for the +array data. The first argument, @emph{element_type}, is a C constant +that represents a valid array element type (See @coderef{cl_elttype}). The function @coderef{si_make_vector} does the same job but allows creating an array with fill pointer, which is adjustable or displaced to another array. @itemize @@ -130,7 +136,11 @@ The function @coderef{si_make_vector} does the same job but allows creating an a @item displacement is either ECL_NIL or a non-negative value with the array displacement. @end itemize -Finally, the function @coderef{si_make_array} does a similar job to @coderef{si_make_vector} but its second argument, @emph{dimension}, can be a list of dimensions, to create a multidimensional array. +Adjustable vector may be adjusted with the function @coderef{si_adjust_vector}. + +Finally, the function @coderef{si_make_array} does a similar job to +@coderef{si_make_vector} but its second argument, @emph{dimension}, +can be a list of dimensions, to create a multidimensional array. @paragraph Examples Create one-dimensional @code{base-string} with room for 11 characters: diff --git a/src/h/external.h b/src/h/external.h index 8066d7827..e3bfc6eee 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -334,6 +334,7 @@ extern ECL_API cl_object APPLY(cl_narg n, cl_objectfn, cl_object *x); extern ECL_API cl_object cl_row_major_aref(cl_object x, cl_object i); extern ECL_API cl_object si_row_major_aset(cl_object x, cl_object i, cl_object v); extern ECL_API cl_object si_make_vector(cl_object etype, cl_object dim, cl_object adj, cl_object fillp, cl_object displ, cl_object disploff); +extern ECL_API cl_object si_adjust_vector(cl_object vector, cl_object dim); /* for open-coding the access while preserving the bounds and type check: */ extern ECL_API void *ecl_row_major_ptr(cl_object arr, cl_index index, cl_index bytes); diff --git a/src/tests/normal-tests/mixed.lsp b/src/tests/normal-tests/mixed.lsp index 0726ead48..0d7522e39 100644 --- a/src/tests/normal-tests/mixed.lsp +++ b/src/tests/normal-tests/mixed.lsp @@ -422,3 +422,10 @@ (LET ((FU 1) (BAR 2)) (+ FU BAR 7)) A"))) + +;; Created: 2022-04-27 +;; Contains: a smoke test for a new operator si:adjust-vector +(test mix.0022.adjust-vector + (let ((vector (si:make-vector t 10 t nil nil nil))) + (si:adjust-vector vector 20) + (is (= 20 (array-total-size vector)))))