diff --git a/src/CHANGELOG b/src/CHANGELOG index f4847bc9d..2d1ce9b08 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -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: ===== diff --git a/src/c/array.d b/src/c/array.d index 2f35edd7e..7ec9fe53b 100644 --- a/src/c/array.d +++ b/src/c/array.d @@ -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); } diff --git a/src/c/file.d b/src/c/file.d index d39060738..9b9d437df 100644 --- a/src/c/file.d +++ b/src/c/file.d @@ -22,6 +22,7 @@ */ #include +#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) { diff --git a/src/c/list.d b/src/c/list.d index 21303133f..b34ae44b8 100644 --- a/src/c/list.d +++ b/src/c/list.d @@ -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); diff --git a/src/c/print.d b/src/c/print.d index 78bf94584..6e3ba227e 100644 --- a/src/c/print.d +++ b/src/c/print.d @@ -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) diff --git a/src/c/read.d b/src/c/read.d index 26d361cc2..be58bb350 100644 --- a/src/c/read.d +++ b/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) diff --git a/src/c/sequence.d b/src/c/sequence.d index dc9f38fc7..8dc8cf861 100644 --- a/src/c/sequence.d +++ b/src/c/sequence.d @@ -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) diff --git a/src/c/structure.d b/src/c/structure.d index 7e08887e9..d7eda2ea8 100644 --- a/src/c/structure.d +++ b/src/c/structure.d @@ -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)) } diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 04c7d2df0..dc1b8ec6c 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -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}, diff --git a/src/c/typespec.d b/src/c/typespec.d index a350fd81f..ce3b217a1 100644 --- a/src/c/typespec.d +++ b/src/c/typespec.d @@ -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 diff --git a/src/h/external.h b/src/h/external.h index 5ae7d8b8c..374d8cfeb 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -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 */ diff --git a/src/lsp/predlib.lsp b/src/lsp/predlib.lsp index 1a9ea6025..6cb2c44ca 100644 --- a/src/lsp/predlib.lsp +++ b/src/lsp/predlib.lsp @@ -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)