mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-02 07:30:55 -08:00
READ/WRITE-SEQUENCE implemented.
This commit is contained in:
jjgarcia
parent
d0cd173cf4
commit
3607ca33c6
12 changed files with 156 additions and 79 deletions
|
|
@ -1510,6 +1510,12 @@ ECLS 0.9b
|
|||
(defmethod foo :after (&key x) ...)
|
||||
but an invalid call (FOO :C 2) is undetected.
|
||||
|
||||
- All streams have from now on element type (UNSIGNED-BYTE 8).
|
||||
READ-CHAR and WRITE-CHAR work on any stream, though, as do
|
||||
READ-BYTE and WRITE-BYTE.
|
||||
|
||||
- READ/WRITE-SEQUENCE implemented.
|
||||
|
||||
|
||||
TODO:
|
||||
=====
|
||||
|
|
|
|||
|
|
@ -28,11 +28,11 @@ object_to_index(cl_object n)
|
|||
case t_fixnum: {
|
||||
cl_fixnum out = fix(n);
|
||||
if (out < 0 || out >= ADIMLIM)
|
||||
FEtype_error_index(n);
|
||||
FEtype_error_index(Cnil, n);
|
||||
return out;
|
||||
}
|
||||
case t_bignum:
|
||||
FEtype_error_index(n);
|
||||
FEtype_error_index(Cnil, n);
|
||||
default:
|
||||
FEtype_error_integer(n);
|
||||
}
|
||||
|
|
|
|||
126
src/c/file.d
126
src/c/file.d
|
|
@ -22,6 +22,7 @@
|
|||
*/
|
||||
|
||||
#include <ecl.h>
|
||||
#include "ecl-inl.h"
|
||||
#include "machines.h"
|
||||
#include "internal.h"
|
||||
|
||||
|
|
@ -133,6 +134,12 @@ BEGIN:
|
|||
}
|
||||
}
|
||||
|
||||
/*
|
||||
* In ECL, all streams have element type (UNSIGNED-BYTE 8). Nevertheless,
|
||||
* READ-CHAR and WRITE-CHAR are allowed in them, and they perform as if
|
||||
* (READ-CHAR) = (CODE-CHAR (READ-BYTE))
|
||||
* (WRITE-CHAR c) = (WRITE-BYTE (CHAR-CODE c))
|
||||
*/
|
||||
cl_object
|
||||
cl_stream_element_type(cl_object strm)
|
||||
{
|
||||
|
|
@ -153,7 +160,6 @@ BEGIN:
|
|||
case smm_output:
|
||||
case smm_io:
|
||||
case smm_probe:
|
||||
x = strm->stream.object0;
|
||||
break;
|
||||
|
||||
case smm_synonym:
|
||||
|
|
@ -163,14 +169,14 @@ BEGIN:
|
|||
case smm_broadcast:
|
||||
x = strm->stream.object0;
|
||||
if (endp(x))
|
||||
return(Ct);
|
||||
break;
|
||||
strm = CAR(x);
|
||||
goto BEGIN;
|
||||
|
||||
case smm_concatenated:
|
||||
x = strm->stream.object0;
|
||||
if (endp(x))
|
||||
return(Ct);
|
||||
break;
|
||||
strm = CAR(x);
|
||||
goto BEGIN;
|
||||
|
||||
|
|
@ -181,12 +187,12 @@ BEGIN:
|
|||
|
||||
case smm_string_input:
|
||||
case smm_string_output:
|
||||
x = @'base-char';
|
||||
break;
|
||||
|
||||
default:
|
||||
error("illegal stream mode");
|
||||
}
|
||||
@(return x)
|
||||
@(return @'byte8')
|
||||
}
|
||||
|
||||
/*----------------------------------------------------------------------
|
||||
|
|
@ -322,7 +328,7 @@ open_stream(cl_object fn, enum smmode smm, cl_object if_exists,
|
|||
x = cl_alloc_object(t_stream);
|
||||
x->stream.mode = (short)smm;
|
||||
x->stream.file = fp;
|
||||
x->stream.object0 = @'base-char';
|
||||
x->stream.object0 = @'byte8';
|
||||
x->stream.object1 = fn;
|
||||
x->stream.int0 = x->stream.int1 = 0;
|
||||
#if !defined(GBC_BOEHM)
|
||||
|
|
@ -753,6 +759,114 @@ writestr_stream(const char *s, cl_object strm)
|
|||
writec_stream(*s++, strm);
|
||||
}
|
||||
|
||||
cl_object
|
||||
si_do_write_sequence(cl_object seq, cl_object stream, cl_object s, cl_object e)
|
||||
{
|
||||
cl_fixnum start = fixnnint(s);
|
||||
cl_fixnum limit = length(seq);
|
||||
cl_fixnum end = (e == Cnil)? limit : fixnnint(e);
|
||||
cl_type t = type_of(seq);
|
||||
|
||||
/* Since we have called length(), we know that SEQ is a valid
|
||||
sequence. Therefore, we only need to check the type of the
|
||||
object, and seq == Cnil i.f.f. t = t_symbol */
|
||||
if (start > limit) {
|
||||
FEtype_error_index(seq, MAKE_FIXNUM(start));
|
||||
} else if (end > limit) {
|
||||
FEtype_error_index(seq, MAKE_FIXNUM(end));
|
||||
} else if (end < start) {
|
||||
;
|
||||
} else if (t == t_cons || t == t_symbol) {
|
||||
seq = nthcdr(start, seq);
|
||||
loop_for_in(seq) {
|
||||
if (start <= end) {
|
||||
cl_write_byte(CAR(seq), stream);
|
||||
} else {
|
||||
goto OUTPUT;
|
||||
}
|
||||
} end_loop_for_in;
|
||||
} else if ((t == t_bitvector) ||
|
||||
(t != t_string && seq->vector.elttype != aet_b8))
|
||||
{
|
||||
FEerror("~S is not of a valid sequence type for WRITE-BYTES",
|
||||
1, seq);
|
||||
} else if (type_of(stream) == t_stream &&
|
||||
(stream->stream.mode == smm_io ||
|
||||
stream->stream.mode == smm_output))
|
||||
{
|
||||
int towrite = end - start + 1;
|
||||
if (fwrite(seq->vector.self.ch + start, sizeof(char),
|
||||
towrite, stream->stream.file) < towrite) {
|
||||
io_error(stream);
|
||||
}
|
||||
} else {
|
||||
unsigned char *p;
|
||||
for (p= seq->vector.self.ch; start <= end; start++, p++) {
|
||||
writec_stream(*p, stream);
|
||||
}
|
||||
}
|
||||
OUTPUT:
|
||||
@(return seq);
|
||||
}
|
||||
|
||||
cl_object
|
||||
si_do_read_sequence(cl_object seq, cl_object stream, cl_object s, cl_object e)
|
||||
{
|
||||
cl_fixnum start = fixnnint(s);
|
||||
cl_fixnum limit = length(seq);
|
||||
cl_fixnum end = (e == Cnil)? limit : fixnnint(e);
|
||||
cl_type t = type_of(seq);
|
||||
|
||||
/* Since we have called length(), we know that SEQ is a valid
|
||||
sequence. Therefore, we only need to check the type of the
|
||||
object, and seq == Cnil i.f.f. t = t_symbol */
|
||||
if (start > limit) {
|
||||
FEtype_error_index(seq, MAKE_FIXNUM(start));
|
||||
} else if (end > limit) {
|
||||
FEtype_error_index(seq, MAKE_FIXNUM(end));
|
||||
} else if (end < start) {
|
||||
;
|
||||
} else if (t == t_cons || t == t_symbol) {
|
||||
seq = nthcdr(start, seq);
|
||||
loop_for_in(seq) {
|
||||
if (start > end) {
|
||||
goto OUTPUT;
|
||||
} else {
|
||||
char c = ecl_getc(stream);
|
||||
if (c == EOF)
|
||||
goto OUTPUT;
|
||||
CAR(seq) = CODE_CHAR(c);
|
||||
start++;
|
||||
}
|
||||
} end_loop_for_in;
|
||||
} else if (t == t_bitvector ||
|
||||
(t != t_string && seq->vector.elttype != aet_b8))
|
||||
{
|
||||
FEerror("~S is not of a valid sequence type for READ-BYTES",
|
||||
1, seq);
|
||||
} else if (type_of(stream) == t_stream &&
|
||||
(stream->stream.mode == smm_io ||
|
||||
stream->stream.mode == smm_output))
|
||||
{
|
||||
int toread = end - start + 1;
|
||||
int n = fread(seq->vector.self.ch + start, sizeof(char),
|
||||
toread, stream->stream.file);
|
||||
if (n < toread && ferror(stream->stream.file))
|
||||
io_error(stream);
|
||||
start += n;
|
||||
} else {
|
||||
unsigned char *p;
|
||||
for (p = seq->vector.self.ch; start <= end; start++, p++) {
|
||||
int c = ecl_getc(stream);
|
||||
if (c == EOF)
|
||||
break;
|
||||
*p = c;
|
||||
}
|
||||
}
|
||||
OUTPUT:
|
||||
@(return MAKE_FIXNUM(start))
|
||||
}
|
||||
|
||||
void
|
||||
flush_stream(cl_object strm)
|
||||
{
|
||||
|
|
|
|||
|
|
@ -322,7 +322,7 @@ cl_object
|
|||
nth(cl_fixnum n, cl_object x)
|
||||
{
|
||||
if (n < 0)
|
||||
FEtype_error_index(MAKE_FIXNUM(n));
|
||||
FEtype_error_index(x, MAKE_FIXNUM(n));
|
||||
/* INV: No need to check for circularity since we visit
|
||||
at most `n' conses */
|
||||
for (; n > 0 && CONSP(x); n--)
|
||||
|
|
@ -344,7 +344,7 @@ cl_object
|
|||
nthcdr(cl_fixnum n, cl_object x)
|
||||
{
|
||||
if (n < 0)
|
||||
FEtype_error_index(MAKE_FIXNUM(n));
|
||||
FEtype_error_index(x, MAKE_FIXNUM(n));
|
||||
while (n-- > 0 && !ENDP(x))
|
||||
x = CDR(x);
|
||||
return(x);
|
||||
|
|
|
|||
|
|
@ -1580,41 +1580,14 @@ cl_write_byte(cl_object integer, cl_object binary_output_stream)
|
|||
{
|
||||
if (!FIXNUMP(integer))
|
||||
FEerror("~S is not a byte.", 1, integer);
|
||||
assert_type_stream(binary_output_stream);
|
||||
writec_stream(fix(integer), binary_output_stream);
|
||||
@(return integer)
|
||||
}
|
||||
|
||||
cl_object
|
||||
si_write_bytes(cl_object stream, cl_object string, cl_object start, cl_object end)
|
||||
{
|
||||
FILE *fp;
|
||||
cl_index is, ie;
|
||||
cl_fixnum written, sofarwritten, towrite;
|
||||
|
||||
assert_type_stream(stream);
|
||||
if (stream->stream.mode == smm_closed)
|
||||
FEclosed_stream(stream);
|
||||
|
||||
is = fix(start); /* FIXME: Unsafe! */
|
||||
ie = fix(end);
|
||||
sofarwritten = is;
|
||||
towrite = ie-is;
|
||||
fp = stream->stream.file;
|
||||
if (fp == NULL) fp = stream->stream.object1->stream.file;
|
||||
while (towrite > 0) {
|
||||
written = write(fileno(fp),
|
||||
string->string.self+sofarwritten, towrite);
|
||||
if (written != -1) {
|
||||
towrite -= written;
|
||||
sofarwritten += written;
|
||||
}
|
||||
else @(return Cnil)
|
||||
}
|
||||
@(return MAKE_FIXNUM(sofarwritten - is))
|
||||
}
|
||||
|
||||
/* FIXME! WRITE-SEQUENCE is missing! */
|
||||
@(defun write-sequence (sequence stream &key (start MAKE_FIXNUM(0)) end)
|
||||
@
|
||||
si_do_write_sequence(sequence, stream, start, end);
|
||||
@)
|
||||
|
||||
void
|
||||
init_print(void)
|
||||
|
|
|
|||
26
src/c/read.d
26
src/c/read.d
|
|
@ -1528,28 +1528,10 @@ CANNOT_PARSE:
|
|||
@(return MAKE_FIXNUM(c))
|
||||
@)
|
||||
|
||||
cl_object
|
||||
si_read_bytes(cl_object stream, cl_object string, cl_object start, cl_object end)
|
||||
{
|
||||
cl_fixnum is, ie, c;
|
||||
FILE *fp;
|
||||
|
||||
assert_type_stream(stream);
|
||||
if (stream->stream.mode == smm_closed)
|
||||
FEclosed_stream(stream);
|
||||
|
||||
/* FIXME! this may fail! We have to check the signs of is, ie, etc.*/
|
||||
is = fix(start);
|
||||
ie = fix(end);
|
||||
fp = stream->stream.file;
|
||||
if (fp == NULL) fp = stream->stream.object0->stream.file;
|
||||
c = fread (string->string.self + is, sizeof(unsigned char),
|
||||
ie - is,
|
||||
fp);
|
||||
@(return ((c < (ie - is))? Cnil : MAKE_FIXNUM(c)))
|
||||
}
|
||||
|
||||
/* FIXME! READ-SEQUENCE is missing! */
|
||||
@(defun read_sequence (sequence stream &key (start MAKE_FIXNUM(0)) end)
|
||||
@
|
||||
return si_do_read_sequence(sequence, stream, start, end);
|
||||
@)
|
||||
|
||||
|
||||
@(defun copy_readtable (&o (from ecl_current_readtable()) to)
|
||||
|
|
|
|||
|
|
@ -101,7 +101,7 @@ elt(cl_object seq, cl_fixnum index)
|
|||
FEwrong_type_argument(@'sequence', seq);
|
||||
}
|
||||
E:
|
||||
FEtype_error_index(MAKE_FIXNUM(index));
|
||||
FEtype_error_index(seq, MAKE_FIXNUM(index));
|
||||
}
|
||||
|
||||
cl_object
|
||||
|
|
@ -147,7 +147,7 @@ elt_set(cl_object seq, cl_fixnum index, cl_object val)
|
|||
FEwrong_type_argument(@'sequence', seq);
|
||||
}
|
||||
E:
|
||||
FEtype_error_index(MAKE_FIXNUM(index));
|
||||
FEtype_error_index(seq, MAKE_FIXNUM(index));
|
||||
}
|
||||
|
||||
@(defun subseq (sequence start &optional end &aux x)
|
||||
|
|
|
|||
|
|
@ -209,7 +209,7 @@ si_rplaca_nthcdr(cl_object x, cl_object idx, cl_object v)
|
|||
assert_type_cons(x);
|
||||
for (i = fixnnint(idx), l = x; i > 0; --i) {
|
||||
l = CDR(l);
|
||||
if (endp(l)) FEtype_error_index(idx);
|
||||
if (endp(l)) FEtype_error_index(x, idx);
|
||||
}
|
||||
CAR(l) = v;
|
||||
@(return v)
|
||||
|
|
@ -229,7 +229,7 @@ si_list_nth(cl_object idx, cl_object x)
|
|||
assert_type_cons(x);
|
||||
for (i = fixnnint(idx), l = x; i > 0; --i) {
|
||||
l = CDR(l);
|
||||
if (endp(l)) FEtype_error_index(idx);
|
||||
if (endp(l)) FEtype_error_index(x, idx);
|
||||
}
|
||||
@(return CAR(l))
|
||||
}
|
||||
|
|
|
|||
|
|
@ -699,7 +699,7 @@ cl_symbols[] = {
|
|||
{"READ-FROM-STRING", CL_ORDINARY, NULL, -1},
|
||||
{"READ-LINE", CL_ORDINARY, cl_read_line, -1},
|
||||
{"READ-PRESERVING-WHITESPACE", CL_ORDINARY, cl_read_preserving_whitespace, -1},
|
||||
{"READ-SEQUENCE", CL_ORDINARY, NULL, -1},
|
||||
{"READ-SEQUENCE", CL_ORDINARY, cl_read_sequence, -1},
|
||||
{"READER-ERROR", CL_ORDINARY, NULL, -1},
|
||||
{"READTABLE", CL_ORDINARY, NULL, -1},
|
||||
{"READTABLE-CASE", CL_ORDINARY, NULL, -1},
|
||||
|
|
@ -925,7 +925,7 @@ cl_symbols[] = {
|
|||
{"WRITE-BYTE", CL_ORDINARY, cl_write_byte, 2},
|
||||
{"WRITE-CHAR", CL_ORDINARY, cl_write_char, -1},
|
||||
{"WRITE-LINE", CL_ORDINARY, cl_write_line, -1},
|
||||
{"WRITE-SEQUENCE", CL_ORDINARY, NULL, -1},
|
||||
{"WRITE-SEQUENCE", CL_ORDINARY, cl_write_sequence, -1},
|
||||
{"WRITE-STRING", CL_ORDINARY, cl_write_string, -1},
|
||||
{"WRITE-TO-STRING", CL_ORDINARY, NULL, -1},
|
||||
{"Y-OR-N-P", CL_ORDINARY, NULL, -1},
|
||||
|
|
@ -1093,7 +1093,7 @@ cl_symbols[] = {
|
|||
{SYS_ "PUT-PROPERTIES", SI_ORDINARY, si_put_properties, -1},
|
||||
{SYS_ "PUT-SYSPROP", SI_ORDINARY, si_put_sysprop, 3},
|
||||
{SYS_ "PUTPROP", SI_ORDINARY, si_putprop, 3},
|
||||
{SYS_ "READ-BYTES", SI_ORDINARY, si_read_bytes, 4},
|
||||
{SYS_ "DO-READ-SEQUENCE", SI_ORDINARY, si_do_read_sequence, 4},
|
||||
{SYS_ "REM-F", SI_ORDINARY, si_rem_f, 2},
|
||||
{SYS_ "REM-SYSPROP", SI_ORDINARY, si_rem_sysprop, 2},
|
||||
{SYS_ "REPLACE-ARRAY", SI_ORDINARY, si_replace_array, 2},
|
||||
|
|
@ -1138,7 +1138,7 @@ cl_symbols[] = {
|
|||
/*{SYS_ "VALID-FUNCTION-NAME-P", SI_ORDINARY, si_valid_function_name_p, 1},*/
|
||||
{SYS_ "UNIVERSAL-ERROR-HANDLER", SI_ORDINARY, NULL, -1},
|
||||
{SYS_ "UNLINK-SYMBOL", SI_ORDINARY, si_unlink_symbol, 1},
|
||||
{SYS_ "WRITE-BYTES", SI_ORDINARY, si_write_bytes, 4},
|
||||
{SYS_ "DO-WRITE-SEQUENCE", SI_ORDINARY, si_do_write_sequence, 4},
|
||||
|
||||
#ifndef CLOS
|
||||
{SYS_ "STRUCTURE-INCLUDE", SI_ORDINARY, NULL, -1},
|
||||
|
|
|
|||
|
|
@ -90,13 +90,13 @@ FEcircular_list(cl_object x)
|
|||
}
|
||||
|
||||
void
|
||||
FEtype_error_index(cl_object x)
|
||||
FEtype_error_index(cl_object seq, cl_object ndx)
|
||||
{
|
||||
cl_error(9, @'simple-type-error', @':format-control',
|
||||
make_simple_string("Index out of bounds ~D"),
|
||||
@':format-arguments', cl_list(1, x),
|
||||
make_simple_string("~S is not a valid index within the sequence ~S"),
|
||||
@':format-arguments', cl_list(2, seq, ndx),
|
||||
@':expected-type', @'fixnum',
|
||||
@':datum', x);
|
||||
@':datum', ndx);
|
||||
}
|
||||
|
||||
void
|
||||
|
|
|
|||
|
|
@ -366,6 +366,8 @@ extern cl_object cl_make_string_input_stream _ARGS((int narg, cl_object strng, .
|
|||
extern cl_object cl_close _ARGS((int narg, cl_object strm, ...));
|
||||
extern cl_object cl_open _ARGS((int narg, cl_object filename, ...));
|
||||
extern cl_object cl_file_position _ARGS((int narg, cl_object file_stream, ...));
|
||||
extern cl_object si_do_write_sequence(cl_object string, cl_object stream, cl_object start, cl_object end);
|
||||
extern cl_object si_do_read_sequence(cl_object string, cl_object stream, cl_object start, cl_object end);
|
||||
|
||||
extern bool input_stream_p(cl_object strm);
|
||||
extern bool output_stream_p(cl_object strm);
|
||||
|
|
@ -974,7 +976,7 @@ extern bool equalp(cl_object x, cl_object y);
|
|||
/* print.c */
|
||||
|
||||
extern cl_object cl_write_byte(cl_object integer, cl_object binary_output_stream);
|
||||
extern cl_object si_write_bytes(cl_object stream, cl_object string, cl_object start, cl_object end);
|
||||
extern cl_object cl_write_sequence _ARGS((int narg, cl_object seq, cl_object stream, ...));
|
||||
extern cl_object cl_write _ARGS((int narg, cl_object x, ...));
|
||||
extern cl_object cl_prin1 _ARGS((int narg, cl_object obj, ...));
|
||||
extern cl_object cl_print _ARGS((int narg, cl_object obj, ...));
|
||||
|
|
@ -1011,7 +1013,7 @@ extern int init_profile(void);
|
|||
|
||||
/* read.c */
|
||||
|
||||
extern cl_object si_read_bytes(cl_object stream, cl_object string, cl_object start, cl_object end);
|
||||
extern cl_object cl_read_sequence _ARGS((int narg, cl_object seq, cl_object stream, ...));
|
||||
extern cl_object cl_readtablep(cl_object readtable);
|
||||
extern cl_object si_string_to_object(cl_object str);
|
||||
extern cl_object si_standard_readtable();
|
||||
|
|
@ -1313,7 +1315,7 @@ extern void FEtype_error_proper_list(cl_object x) __attribute__((noreturn,regpar
|
|||
extern void FEtype_error_alist(cl_object x) __attribute__((noreturn,regparm(2)));
|
||||
extern void FEtype_error_stream(cl_object x) __attribute__((noreturn,regparm(2)));
|
||||
extern void FEcircular_list(cl_object x) __attribute__((noreturn,regparm(2)));
|
||||
extern void FEtype_error_index(cl_object x) __attribute__((noreturn,regparm(2)));
|
||||
extern void FEtype_error_index(cl_object seq, cl_object ndx) __attribute__((noreturn,regparm(2)));
|
||||
extern void FEtype_error_string(cl_object x) __attribute__((noreturn,regparm(2)));
|
||||
|
||||
/* unixfsys.c */
|
||||
|
|
|
|||
|
|
@ -206,7 +206,7 @@ has no fill-pointer, and is not adjustable."
|
|||
(put-sysprop (car l) 'TYPE-PREDICATE (cdr l)))
|
||||
|
||||
(defconstant +upgraded-array-element-types+
|
||||
'(BIT BASE-CHAR BYTE8 INTEGER8 FIXNUM SHORT-FLOAT LONG-FLOAT T))
|
||||
'(BASE-CHAR BIT BYTE8 INTEGER8 FIXNUM SHORT-FLOAT LONG-FLOAT T))
|
||||
|
||||
(defun upgraded-array-element-type (element-type &optional env)
|
||||
(dolist (v +upgraded-array-element-types+ 'T)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue