Merge branch 'fix-678' into 'develop'

core: add a new utility 'si_adjust_vector' to arrays.d

Closes #678

See merge request embeddable-common-lisp/ecl!271

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)

src/c/file.d

@@ -4667,11 +4667,7 @@ static void
 seq_out_enlarge_vector(cl_object strm)
 {
   cl_object vector = SEQ_OUTPUT_VECTOR(strm);
-  if (!ECL_ADJUSTABLE_ARRAY_P(vector)) {
-    FEerror("Can't adjust the dimensions of the sequence of sequence stream ~A", 1, strm);
-  }
-  vector = _ecl_funcall3(@'adjust-array', vector,
-                         ecl_ash(ecl_make_fixnum(vector->vector.dim), 1));
+  si_adjust_vector(vector, ecl_ash(ecl_make_fixnum(vector->vector.dim), 1));
   SEQ_OUTPUT_VECTOR(strm) = vector;
 }
 

src/c/serialize.d

@@ -97,8 +97,7 @@ alloc(pool_t pool, cl_index size)
   cl_index next_fillp = fillp + bytes;
   if (next_fillp >= pool->data->vector.dim) {
     cl_index new_dim = next_fillp + next_fillp / 2;
-    pool->data = _ecl_funcall3(@'adjust-array', pool->data,
-                               ecl_make_fixnum(new_dim));
+    pool->data = si_adjust_vector(pool->data, ecl_make_fixnum(new_dim));
   }
   pool->data->vector.fillp = next_fillp;
   return fillp;

src/c/string.d

@@ -922,10 +922,9 @@ nstring_case(cl_narg narg, cl_object fun, ecl_casefun casefun, ecl_va_list ARGS)
     if (output_size < output->base_string.dim) {
       break;
     }
-    output = _ecl_funcall3(@'adjust-array', output,
-                           ecl_make_fixnum(input_size > output_size
-                                           ? input_size
-                                           : output_size + 128));
+    output = si_adjust_vector(output, ecl_make_fixnum(input_size > output_size
+                                                      ? input_size
+                                                      : output_size + 128));
   } while (1);
   output->base_string.fillp = output_size;
   if (ecl_fits_in_base_string(output)) {

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)},

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)

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:

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);

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)))))