From 45536ebe85bcc7285089799a8a1e7f0370f74976 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <lloda@sarc.name>
Date: Thu, 25 Nov 2021 15:58:41 +0100
Subject: [PATCH] New function array-mutable?

* libguile/arrays.h
* libguile/arrays.c (scm_array_mutable_p): New function.
* doc/ref/api-data.texi: Documentation.
* NEWS: Update.
---
 NEWS                  |  4 ++++
 doc/ref/api-data.texi | 29 +++++++++++++++++++++++++++++
 libguile/arrays.c     | 27 +++++++++++++++++++++------
 libguile/arrays.h     |  1 +
 4 files changed, 55 insertions(+), 6 deletions(-)

diff --git a/NEWS b/NEWS
index 710b8ddda..b72cc8696 100644
--- a/NEWS
+++ b/NEWS
@@ -39,6 +39,10 @@ The functions `u8vector-copy' `s8vector-copy' `u16vector-copy'
 `f64vector-copy!'  `c32vector-copy!'  `c64vector-copy!' have been
 added. See SRFI-4 - Guile extensions" in the manual.
 
+** New function array-mutable?
+
+See "Array procedures" in the manual.
+
 ** `bytevector-fill!' supports partial fill through optional arguments
 
 This is an extension to the r6rs procedure. See "Manipulating
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index 1df88e755..b74376039 100644
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -7345,6 +7345,35 @@ but it is not used.  You should always pass @code{SCM_UNDEFINED} as
 its value.
 @end deffn
 
+@deffn {Scheme Procedure} array-mutable? array
+@deffnx {C Function} scm_array_mutable_p (array)
+Return @code{#t} if the root of @var{array} is mutable, and @code{#f}
+otherwise.
+
+Most literal arrays are immutable.
+@example
+(let ((a #(1 2 3)))
+  (array-set! a 'x 0) @result{} error!
+  a)
+(array-mutable? #(1 2 3)) @result{} #f
+@end example
+
+@example
+(let ((a (array-copy #(1 2 3))))
+  (array-set! a 'x 0) ; ok
+  a) @result{} #(x 2 3)
+(array-mutable? (vector-copy #(1 2 3))) @result{} #t
+@end example
+
+Arrays with empty roots are not considered immutable because
+@code{array-set!} operations with valid indices won't fail (since there
+are no valid indices).
+
+@example
+(array-mutable? #()) @result{} #t
+@end example
+@end deffn
+
 @deffn {Scheme Procedure} typed-array? obj type
 @deffnx {C Function} scm_typed_array_p (obj, type)
 Return @code{#t} if the @var{obj} is an array of type @var{type}, and
diff --git a/libguile/arrays.c b/libguile/arrays.c
index 924ee0094..6963f7cd9 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -28,10 +28,17 @@
 #include <errno.h>
 #include <string.h>
 
+#include "arrays.h"
 #include "array-map.h"
+#include "generalized-vectors.h"
+
 #include "bitvectors.h"
 #include "boolean.h"
 #include "bytevectors.h"
+#include "strings.h"
+#include "uniform.h"
+#include "vectors.h"
+
 #include "chars.h"
 #include "dynwind.h"
 #include "eq.h"
@@ -39,7 +46,6 @@
 #include "eval.h"
 #include "feature.h"
 #include "fports.h"
-#include "generalized-vectors.h"
 #include "gsubr.h"
 #include "list.h"
 #include "modules.h"
@@ -49,11 +55,6 @@
 #include "read.h"
 #include "srfi-13.h"
 #include "srfi-4.h"
-#include "strings.h"
-#include "uniform.h"
-#include "vectors.h"
-
-#include "arrays.h"
 
 SCM_INTERNAL SCM scm_i_array_ref (SCM v,
                                   SCM idx0, SCM idx1, SCM idxN);
@@ -90,6 +91,20 @@ SCM_DEFINE (scm_array_p_2, "array?", 1, 0, 0,
 }
 #undef FUNC_NAME
 
+SCM_DEFINE (scm_array_mutable_p, "array-mutable?", 1, 0, 0,
+            (SCM obj),
+            "Return @code{#t} if the root of array @var{obj} is mutable, and\n"
+            "@code{#f} otherwise.")
+#define FUNC_NAME s_scm_array_mutable_p
+{
+  scm_t_array_handle h;
+  scm_array_get_handle (obj, &h);
+  SCM val = scm_from_bool (h.writable_elements == h.elements);
+  scm_array_handle_release (&h);
+  return val;
+}
+#undef FUNC_NAME
+
 /* The array type predicate, with an extra argument kept for backward
    compatibility.  Note that we can't use `SCM_DEFINE' directly because there
    would be an argument count mismatch that would be caught by
diff --git a/libguile/arrays.h b/libguile/arrays.h
index 5457ddb95..e2306cabf 100644
--- a/libguile/arrays.h
+++ b/libguile/arrays.h
@@ -62,6 +62,7 @@ SCM_API SCM scm_array_rank (SCM ra);
 SCM_API int scm_is_array (SCM obj);
 SCM_API SCM scm_array_p (SCM v, SCM unused);
 SCM_INTERNAL SCM scm_array_p_2 (SCM);
+SCM_API SCM scm_array_mutable_p (SCM a);
 
 SCM_API int scm_is_typed_array (SCM obj, SCM type);
 SCM_API SCM scm_typed_array_p (SCM v, SCM type);
-- 
2.30.2

