mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2025-12-15 15:21:03 -08:00
Code Issues Projects Releases Packages Wiki Activity

Add support for gray:stream-file-string-length

Browse source
This commit is contained in:
Tarn W. Burton 2024-01-13 10:26:35 -05:00
parent db4e3a0013
commit e554673006
No known key found for this signature in database
GPG key ID: B4E3D65DE1CE325A
5 changed files with 142 additions and 65 deletions
Download patch file Download diff file Expand all files Collapse all files

192
src/c/file.d
View file

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

1
src/c/symbols_list.h
View file

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

12
src/clos/streams.lsp
View file

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

1
src/h/external.h
View file

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

1
src/h/object.h
View file

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