From e554673006602b48f5823a95a37351adc8770bf2 Mon Sep 17 00:00:00 2001
From: "Tarn W. Burton" <twburton@gmail.com>
Date: Sat, 13 Jan 2024 10:26:35 -0500
Subject: [PATCH 1/2] Add support for gray:stream-file-string-length

---
 src/c/file.d         | 192 ++++++++++++++++++++++++++++---------------
 src/c/symbols_list.h |   1 +
 src/clos/streams.lsp |  12 +++
 src/h/external.h     |   1 +
 src/h/object.h       |   1 +
 5 files changed, 142 insertions(+), 65 deletions(-)

diff --git a/src/c/file.d b/src/c/file.d
index a6a76dbef..0a96562b8 100644
--- a/src/c/file.d
+++ b/src/c/file.d
@@ -224,6 +224,20 @@ not_output_finish_output(cl_object strm)
   not_an_output_stream(strm);
 }
 
+static cl_object
+not_output_string_length(cl_object strm, cl_object string)
+{
+  not_an_output_stream(strm);
+  return 0;
+}
+
+static cl_object
+not_file_string_length(cl_object strm, cl_object string)
+{
+  not_a_file_stream(strm);
+  return 0;
+}
+
 static int
 unknown_column(cl_object strm)
 {
@@ -1158,6 +1172,51 @@ utf_8_encoder(cl_object stream, unsigned char *buffer, ecl_character c)
 }
 #endif
 
+static cl_index
+compute_char_size(cl_object stream, ecl_character c)
+{
+  unsigned char buffer[5];
+  int l = 0;
+  if (c == ECL_CHAR_CODE_NEWLINE) {
+    int flags = stream->stream.flags;
+    if (flags & ECL_STREAM_CR) {
+      l += stream->stream.encoder(stream, buffer, ECL_CHAR_CODE_RETURN);
+      if (flags & ECL_STREAM_LF)
+        l += stream->stream.encoder(stream, buffer,
+                                    ECL_CHAR_CODE_LINEFEED);
+    } else {
+      l += stream->stream.encoder(stream, buffer, ECL_CHAR_CODE_LINEFEED);
+    }
+  } else {
+    l += stream->stream.encoder(stream, buffer, c);
+  }
+  return l;
+}
+
+cl_object
+file_string_length(cl_object stream, cl_object string)
+{
+  cl_fixnum l = 0;
+  switch (ecl_t_of(string)) {
+#ifdef ECL_UNICODE
+  case t_string:
+#endif
+  case t_base_string: {
+    cl_index i;
+    for (i = 0; i < string->base_string.fillp; i++) {
+      l += compute_char_size(stream, ecl_char(string, i));
+    }
+    break;
+  }
+  case t_character:
+    l = compute_char_size(stream, ECL_CHAR_CODE(string));
+    break;
+  default:
+    FEwrong_type_nth_arg(@[file-string-length], 2, string, @[string]);
+  }
+  return ecl_make_fixnum(l);
+}
+
 /********************************************************************************
  * CLOS STREAMS
  */
@@ -1331,6 +1390,12 @@ clos_stream_set_position(cl_object strm, cl_object pos)
   return _ecl_funcall3(@'gray::stream-file-position', strm, pos);
 }
 
+static cl_object
+clos_stream_string_length(cl_object strm, cl_object string)
+{
+  return _ecl_funcall3(@'gray::stream-file-string-length', strm, string);
+}
+
 static int
 clos_stream_column(cl_object strm)
 {
@@ -1373,6 +1438,7 @@ const struct ecl_file_ops clos_stream_ops = {
   clos_stream_length,
   clos_stream_get_position,
   clos_stream_set_position,
+  clos_stream_string_length,
   clos_stream_column,
   clos_stream_close
 };
@@ -1405,6 +1471,26 @@ str_out_get_position(cl_object strm)
   return ecl_make_unsigned_integer(STRING_OUTPUT_STRING(strm)->base_string.fillp);
 }
 
+static cl_object
+str_out_string_length(cl_object strm, cl_object string)
+{
+  cl_fixnum l = 0;
+  switch (ecl_t_of(string)) {
+#ifdef ECL_UNICODE
+  case t_string:
+#endif
+  case t_base_string:
+    l = string->base_string.fillp;
+    break;
+  case t_character:
+    l = 1;
+    break;
+  default:
+    FEwrong_type_nth_arg(@[file-string-length], 2, string, @[string]);
+  }
+  return ecl_make_fixnum(l);
+}
+
 static cl_object
 str_out_set_position(cl_object strm, cl_object pos)
 {
@@ -1454,6 +1540,7 @@ const struct ecl_file_ops str_out_ops = {
   not_a_file_stream, /* length */
   str_out_get_position,
   str_out_set_position,
+  str_out_string_length,
   generic_column,
   generic_close
 };
@@ -1642,6 +1729,7 @@ const struct ecl_file_ops str_in_ops = {
   not_a_file_stream, /* length */
   str_in_get_position,
   str_in_set_position,
+  not_output_string_length,
   unknown_column,
   generic_close
 };
@@ -1838,6 +1926,7 @@ const struct ecl_file_ops two_way_ops = {
   not_a_file_stream, /* length */
   generic_always_nil, /* get_position */
   generic_set_position,
+  not_file_string_length,
   two_way_column,
   two_way_close
 };
@@ -1975,6 +2064,15 @@ broadcast_set_position(cl_object strm, cl_object pos)
   return ecl_file_position_set(ECL_CONS_CAR(l), pos);
 }
 
+cl_object
+broadcast_string_length(cl_object strm, cl_object string)
+{
+  cl_object l = BROADCAST_STREAM_LIST(strm);
+  if (Null(l))
+    return ecl_make_fixnum(1);
+  return ecl_file_string_length(ECL_CONS_CAR(ecl_last(l, 1)), string);
+}
+
 static int
 broadcast_column(cl_object strm)
 {
@@ -2022,6 +2120,7 @@ const struct ecl_file_ops broadcast_ops = {
   broadcast_length,
   broadcast_get_position,
   broadcast_set_position,
+  broadcast_string_length,
   broadcast_column,
   broadcast_close
 };
@@ -2207,6 +2306,7 @@ const struct ecl_file_ops echo_ops = {
   not_a_file_stream, /* length */
   generic_always_nil, /* get_position */
   generic_set_position,
+  not_file_string_length,
   echo_column,
   echo_close
 };
@@ -2353,6 +2453,7 @@ const struct ecl_file_ops concatenated_ops = {
   not_a_file_stream, /* length */
   generic_always_nil, /* get_position */
   generic_set_position,
+  not_output_string_length,
   unknown_column,
   concatenated_close
 };
@@ -2527,6 +2628,12 @@ synonym_set_position(cl_object strm, cl_object pos)
   return ecl_file_position_set(SYNONYM_STREAM_STREAM(strm), pos);
 }
 
+static cl_object
+synonym_string_length(cl_object strm, cl_object string)
+{
+  return ecl_file_string_length(SYNONYM_STREAM_STREAM(strm), string);
+}
+
 static int
 synonym_column(cl_object strm)
 {
@@ -2562,6 +2669,7 @@ const struct ecl_file_ops synonym_ops = {
   synonym_length,
   synonym_get_position,
   synonym_set_position,
+  synonym_string_length,
   synonym_column,
   generic_close
 };
@@ -3086,6 +3194,7 @@ const struct ecl_file_ops io_file_ops = {
   io_file_length,
   io_file_get_position,
   io_file_set_position,
+  file_string_length,
   generic_column,
   io_file_close
 };
@@ -3119,6 +3228,7 @@ const struct ecl_file_ops output_file_ops = {
   io_file_length,
   io_file_get_position,
   io_file_set_position,
+  file_string_length,
   generic_column,
   io_file_close
 };
@@ -3152,6 +3262,7 @@ const struct ecl_file_ops input_file_ops = {
   io_file_length,
   io_file_get_position,
   io_file_set_position,
+  not_output_string_length,
   unknown_column,
   io_file_close
 };
@@ -3738,6 +3849,7 @@ const struct ecl_file_ops io_stream_ops = {
   io_stream_length,
   io_stream_get_position,
   io_stream_set_position,
+  file_string_length,
   generic_column,
   io_stream_close
 };
@@ -3771,6 +3883,7 @@ const struct ecl_file_ops output_stream_ops = {
   io_stream_length,
   io_stream_get_position,
   io_stream_set_position,
+  file_string_length,
   generic_column,
   io_stream_close
 };
@@ -3804,6 +3917,7 @@ const struct ecl_file_ops input_stream_ops = {
   io_stream_length,
   io_stream_get_position,
   io_stream_set_position,
+  not_output_string_length,
   unknown_column,
   io_stream_close
 };
@@ -3948,6 +4062,7 @@ const struct ecl_file_ops winsock_stream_io_ops = {
   not_a_file_stream,
   generic_always_nil, /* get_position */
   generic_set_position,
+  file_string_length,
   generic_column,
 
   winsock_stream_close
@@ -3982,6 +4097,7 @@ const struct ecl_file_ops winsock_stream_output_ops = {
   not_a_file_stream,
   generic_always_nil, /* get_position */
   generic_set_position,
+  file_string_length,
   generic_column,
 
   winsock_stream_close
@@ -4016,6 +4132,7 @@ const struct ecl_file_ops winsock_stream_input_ops = {
   not_a_file_stream,
   generic_always_nil, /* get_position */
   generic_set_position,
+  not_output_string_length,
   unknown_column,
 
   winsock_stream_close
@@ -4121,6 +4238,7 @@ const struct ecl_file_ops wcon_stream_io_ops = {
   not_a_file_stream,
   generic_always_nil, /* get_position */
   generic_set_position,
+  file_string_length,
   generic_column,
 
   generic_close,
@@ -4593,6 +4711,7 @@ const struct ecl_file_ops seq_in_ops = {
   not_a_file_stream, /* length */
   seq_in_get_position,
   seq_in_set_position,
+  not_output_string_length,
   unknown_column,
   generic_close
 };
@@ -4798,6 +4917,7 @@ const struct ecl_file_ops seq_out_ops = {
   not_a_file_stream, /* length */
   seq_out_get_position,
   seq_out_set_position,
+  not_output_string_length,
   generic_column,
   generic_close
 };
@@ -4988,6 +5108,12 @@ ecl_file_position_set(cl_object strm, cl_object pos)
   return stream_dispatch_table(strm)->set_position(strm, pos);
 }
 
+cl_object
+ecl_file_string_length(cl_object strm, cl_object string)
+{
+  return stream_dispatch_table(strm)->string_length(strm, string);
+}
+
 bool
 ecl_input_stream_p(cl_object strm)
 {
@@ -5050,74 +5176,10 @@ writestr_stream(const char *s, cl_object strm)
   si_put_buffer_string(buffer);
 }
 
-static cl_index
-compute_char_size(cl_object stream, ecl_character c)
-{
-  unsigned char buffer[5];
-  int l = 0;
-  if (c == ECL_CHAR_CODE_NEWLINE) {
-    int flags = stream->stream.flags;
-    if (flags & ECL_STREAM_CR) {
-      l += stream->stream.encoder(stream, buffer, ECL_CHAR_CODE_RETURN);
-      if (flags & ECL_STREAM_LF)
-        l += stream->stream.encoder(stream, buffer,
-                                    ECL_CHAR_CODE_LINEFEED);
-    } else {
-      l += stream->stream.encoder(stream, buffer, ECL_CHAR_CODE_LINEFEED);
-    }
-  } else {
-    l += stream->stream.encoder(stream, buffer, c);
-  }
-  return l;
-}
-
 cl_object
 cl_file_string_length(cl_object stream, cl_object string)
 {
-  cl_fixnum l = 0;
-  /* This is a stupid requirement from the spec. Why returning 1???
-   * Why not simply leaving the value unspecified, as with other
-   * streams one cannot write to???
-   */
- BEGIN:
-#ifdef ECL_CLOS_STREAMS
-  if (ECL_INSTANCEP(stream)) {
-    @(return ECL_NIL);
-  }
-#endif
-  unlikely_if (!ECL_ANSI_STREAM_P(stream)) {
-    FEwrong_type_only_arg(@[file-string-length], stream, @[stream]);
-  }
-  if (stream->stream.mode == ecl_smm_broadcast) {
-    stream = BROADCAST_STREAM_LIST(stream);
-    if (Null(stream)) {
-      @(return ecl_make_fixnum(1));
-    } else {
-      stream = ECL_CONS_CAR(ecl_last(stream, 1));
-      goto BEGIN;
-    }
-  }
-  unlikely_if (!ECL_FILE_STREAM_P(stream)) {
-    not_a_file_stream(stream);
-  }
-  switch (ecl_t_of(string)) {
-#ifdef ECL_UNICODE
-  case t_string:
-#endif
-  case t_base_string: {
-    cl_index i;
-    for (i = 0; i < string->base_string.fillp; i++) {
-      l += compute_char_size(stream, ecl_char(string, i));
-    }
-    break;
-  }
-  case t_character:
-    l = compute_char_size(stream, ECL_CHAR_CODE(string));
-    break;
-  default:
-    FEwrong_type_nth_arg(@[file-string-length], 2, string, @[string]);
-  }
-  @(return ecl_make_fixnum(l));
+  @(return ecl_file_string_length(stream, string));
 }
 
 cl_object
diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h
index 8b53a5a49..f335bad26 100644
--- a/src/c/symbols_list.h
+++ b/src/c/symbols_list.h
@@ -1860,6 +1860,7 @@ cl_symbols[] = {
 {GRAY_ "STREAM-FILE-DESCRIPTOR" ECL_FUN(NULL, NULL, -1) ECL_VAR(GRAY_ORDINARY, OBJNULL)},
 {GRAY_ "STREAM-FILE-LENGTH" ECL_FUN(NULL, NULL, -1) ECL_VAR(GRAY_ORDINARY, OBJNULL)},
 {GRAY_ "STREAM-FILE-POSITION" ECL_FUN(NULL, NULL, -1) ECL_VAR(GRAY_ORDINARY, OBJNULL)},
+{GRAY_ "STREAM-FILE-STRING-LENGTH" ECL_FUN(NULL, NULL, -1) ECL_VAR(GRAY_ORDINARY, OBJNULL)},
 {GRAY_ "STREAM-FINISH-OUTPUT" ECL_FUN(NULL, NULL, -1) ECL_VAR(GRAY_ORDINARY, OBJNULL)},
 {GRAY_ "STREAM-FORCE-OUTPUT" ECL_FUN(NULL, NULL, -1) ECL_VAR(GRAY_ORDINARY, OBJNULL)},
 {GRAY_ "STREAM-FRESH-LINE" ECL_FUN(NULL, NULL, -1) ECL_VAR(GRAY_ORDINARY, OBJNULL)},
diff --git a/src/clos/streams.lsp b/src/clos/streams.lsp
index 27888cae0..eb49155fd 100644
--- a/src/clos/streams.lsp
+++ b/src/clos/streams.lsp
@@ -212,6 +212,10 @@
   (:documentation
    "This is like CL:FILE-LENGTH, but for Gray streams."))
 
+(defgeneric stream-file-string-length (stream string)
+  (:documentation
+   "This is like CL:FILE-STRING-LENGTH, but for Gray streams."))
+
 (defgeneric stream-file-descriptor (stream &optional direction)
   (:documentation
    "Return the file-descriptor underlaying STREAM, or NIL if not
@@ -618,6 +622,14 @@
 (defmethod stream-file-length ((stream t))
   (error 'type-error :datum stream :expected-type 'file-stream))
 
+;; FILE-STRING-LENGTH
+
+(defmethod stream-file-string-length ((stream ansi-stream) string)
+  (file-string-length stream string))
+
+(defmethod stream-file-string-length ((stream fundamental-character-output-stream) string)
+  nil)
+
 ;; STREAM-P
 
 (defmethod streamp ((stream stream))
diff --git a/src/h/external.h b/src/h/external.h
index 3ad3ce805..3a909974d 100755
--- a/src/h/external.h
+++ b/src/h/external.h
@@ -738,6 +738,7 @@ extern ECL_API bool ecl_listen_stream(cl_object strm);
 extern ECL_API cl_object ecl_file_position(cl_object strm);
 extern ECL_API cl_object ecl_file_position_set(cl_object strm, cl_object disp);
 extern ECL_API cl_object ecl_file_length(cl_object strm);
+extern ECL_API cl_object ecl_file_string_length(cl_object strm, cl_object string);
 extern ECL_API int ecl_file_column(cl_object strm);
 extern ECL_API cl_fixnum ecl_normalize_stream_element_type(cl_object element);
 extern ECL_API cl_object ecl_make_stream_from_FILE(cl_object fname, void *fd, enum ecl_smmode smm, cl_fixnum byte_size, int flags, cl_object external_format);
diff --git a/src/h/object.h b/src/h/object.h
index 915cd2604..459dfb7f5 100644
--- a/src/h/object.h
+++ b/src/h/object.h
@@ -602,6 +602,7 @@ struct ecl_file_ops {
         cl_object (*length)(cl_object strm);
         cl_object (*get_position)(cl_object strm);
         cl_object (*set_position)(cl_object strm, cl_object pos);
+        cl_object (*string_length)(cl_object strm, cl_object string);
         int (*column)(cl_object strm);
 
         cl_object (*close)(cl_object strm);

From 10fa901e98f80f9767f11083e714bea190fc3620 Mon Sep 17 00:00:00 2001
From: "Tarn W. Burton" <twburton@gmail.com>
Date: Sat, 13 Jan 2024 10:32:59 -0500
Subject: [PATCH 2/2] Update for gray:stream-file-string-length

---
 CHANGELOG | 13 ++++++++-----
 1 file changed, 8 insertions(+), 5 deletions(-)

diff --git a/CHANGELOG b/CHANGELOG
index 413c2f3d7..8a605b86c 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -32,11 +32,14 @@
 - Add gray-streams module. This makes it possible to load Gray stream
   support via ~(require '#:gray-streams)~ versus calling the internal
   function ~gray::redefine-cl-functions~.
-- Add support for some Gray stream extensions. Specifically, the generic
-  functions ~gray-streams:stream-line-length~ and
-  ~gray-streams:stream-file-length~ have been added. The former allows
-  stream specific line lengths when ~cl:*print-right-margin*~ is NIL. The
-  latter allows Gray streams to implement ~cl:file-length~.
+- Add support for some Gray stream extensions by adding the following
+  generic functions.
+  1) ~gray:stream-line-length~ which allows stream specific line lengths
+     when ~cl:*print-right-margin*~ is NIL.
+  2) ~gray:stream-file-length~ which allows Gray streams to implement
+     ~cl:file-length~.
+  3) ~gray:stream-file-string-length~ which allows Gray streams to
+     implement ~cl:file-string-length~.
 - Various bug fixes for Gray streams.
     
 * 23.9.9 changes since 21.2.1