From ad50724d475556e192ef137fa1ad19a49ccec7dd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Sat, 24 May 2025 08:55:18 +0200 Subject: [PATCH] exceptions: make stream.d usable in the early env This is a step towards introducing the I/O system. --- src/c/error.d | 72 +++++++++++++++++++++++++-- src/c/file.d | 42 ++++++++++++++++ src/c/stream.d | 91 +++++++++++++++------------------- src/c/streams/strm_common.d | 54 ++++++-------------- src/c/streams/strm_composite.d | 1 - src/c/symbols_list.h | 2 + src/h/external.h | 23 ++++++++- src/h/internal.h | 4 +- src/h/object.h | 11 ++++ 9 files changed, 203 insertions(+), 97 deletions(-) diff --git a/src/c/error.d b/src/c/error.d index 82c151520..8c59ddeb2 100644 --- a/src/c/error.d +++ b/src/c/error.d @@ -62,6 +62,8 @@ ecl_exception_handler(cl_object o) if (ECL_EXCEPTIONP(o)) { cl_object arg1 = o->exception.arg1; cl_object arg2 = o->exception.arg2; + cl_object arg3 = o->exception.arg3; + void *arg4 = o->exception.arg4; cl_object hand = @'si::universal-error-handler'; switch (o->exception.ex_type) { /* General conditions */ @@ -71,6 +73,37 @@ ecl_exception_handler(cl_object o) case ECL_EX_CERROR: ecl_enable_interrupts(); return _ecl_funcall4(hand, ECL_T, arg1, arg2); + /* Specific conditions */ + case ECL_EX_BADARG: + FEwrong_type_argument(arg1, arg2); + break; + case ECL_EX_BADARG_ONLY: + FEwrong_type_only_arg(arg1, arg2, arg3); + break; + case ECL_EX_BADARG_NTH: + FEwrong_type_nth_arg(arg1, (cl_narg)arg4, arg2, arg3); + break; + case ECL_EX_UNSATISFIED: + FEwrong_type_pred_arg(arg1, arg2); + break; + case ECL_EX_STRM_BADELT: + FEwrong_type_strm_elt(arg1, arg2); + break; + case ECL_EX_STRM_CLOSED: + FEclosed_stream(arg1); + break; + case ECL_EX_STRM_UNREAD: + FEunread_stream(arg1, arg2); + break; + case ECL_EX_EOF: + FEend_of_file(arg1); + break; + case ECL_EX_NIY: + FEerror("The operation is not implemented yet.", 0); + break; + case ECL_EX_NAO: + FEerror("The operation is not applicable to ~A.", 1, arg1); + break; /* Stack conditions */ case ECL_EX_CS_OVR: CEstack_overflow(@'ext::c-stack', arg1, arg2); @@ -273,7 +306,7 @@ FEreader_error(const char *s, cl_object stream, int narg, ...) } else { /* Actual reader error */ cl_object prefix = @"Reader error in file ~S, position ~D:~%"; - cl_object position = cl_file_position(1, stream); + cl_object position = ecl_file_position(stream); message = si_base_string_concatenate(2, prefix, message); args_list = cl_listX(3, stream, position, args_list); si_signal_simple_error(6, @@ -313,6 +346,16 @@ FEclosed_stream(cl_object strm) cl_error(3, @'stream-error', @':stream', strm); } +void +FEunread_stream(cl_object strm, cl_object twice) +{ + if(Null(twice)) { + FEerror("Error when using UNREAD-CHAR on stream ~D", 1, strm); + } else { + FEerror("Used UNREAD-CHAR twice on stream ~D", 1, strm); + } +} + cl_object si_signal_type_error(cl_object value, cl_object type) { @@ -326,6 +369,25 @@ FEwrong_type_argument(cl_object type, cl_object value) si_signal_type_error(value, cl_symbol_or_object(type)); } +void +FEwrong_type_pred_arg(cl_object type, cl_object value) +{ + cl_object predicate = cl_symbol_or_object(type); + cl_object expected = cl_list(2, @'satisfies', predicate); + si_signal_type_error(value, expected); +} + +void +FEwrong_type_strm_elt(cl_object type, cl_object value) +{ + cl_object expected = cl_symbol_or_object(type); + cl_error(9, @'simple-type-error', @':format-control', + @"~A stream element type is not ~S.", + @':format-arguments', cl_list(2, value, expected), + @':expected-type', expected, + @':datum', cl_stream_element_type(value)); +} + void FEwrong_type_only_arg(cl_object function, cl_object value, cl_object type) { @@ -461,8 +523,12 @@ FEtimeout() void FEwrong_num_arguments(cl_object fun) { - fun = cl_symbol_or_object(fun); - FEprogram_error("Wrong number of arguments passed to function ~S.", 1, fun); + if (Null(fun)) { + FEprogram_error("Wrong number of arguments passed to an anonymous function", 0); + } else { + fun = cl_symbol_or_object(fun); + FEprogram_error("Wrong number of arguments passed to function ~S.", 1, fun); + } } void diff --git a/src/c/file.d b/src/c/file.d index f89192c0e..5feddfa38 100644 --- a/src/c/file.d +++ b/src/c/file.d @@ -151,3 +151,45 @@ ecl_normalize_stream_element_type(cl_object element_type) @ @(return ecl_stream_dispatch_table(strm)->close(strm)); @) + +cl_object +si_file_stream_fd(cl_object s) +{ + cl_object ret; + + unlikely_if (!ECL_FILE_STREAM_P(s)) { + ecl_not_a_file_stream(s); + } + + switch ((enum ecl_smmode)s->stream.mode) { + case ecl_smm_input: + case ecl_smm_output: + case ecl_smm_io: + ret = ecl_make_fixnum(fileno(IO_STREAM_FILE(s))); + break; + case ecl_smm_input_file: + case ecl_smm_output_file: + case ecl_smm_io_file: + ret = ecl_make_fixnum(IO_FILE_DESCRIPTOR(s)); + break; + default: + ecl_internal_error("not a file stream"); + } + @(return ret); +} + +@(defun file-position (file_stream &o position) + cl_object output; +@ + if (Null(position)) { + output = ecl_file_position(file_stream); + } else { + if (position == @':start') { + position = ecl_make_fixnum(0); + } else if (position == @':end') { + position = ECL_NIL; + } + output = ecl_file_position_set(file_stream, position); + } + @(return output); +@) diff --git a/src/c/stream.d b/src/c/stream.d index 73c8f7abd..df59006e5 100644 --- a/src/c/stream.d +++ b/src/c/stream.d @@ -18,6 +18,21 @@ #include #include +/* FIXME for now we break the dependency chain for NUCL, but later we want to + bring proto-clos into the early runtime and pull clos streams with it. */ +#ifdef ECL_NUCL +# undef ECL_CLOS_STREAMS +#endif + +static ecl_character +_ecl_char_code(cl_object c) +{ + if (ecl_unlikely(!ECL_CHARACTERP(c))) { + ecl_ferror(ECL_EX_BADARG, @[character], c); + } + return ECL_CHAR_CODE(c); +} + #ifdef ECL_CLOS_STREAMS extern const struct ecl_file_ops clos_stream_ops; #endif @@ -66,7 +81,7 @@ ecl_stream_dispatch_table(cl_object strm) } #endif if (!ECL_ANSI_STREAM_P(strm)) - FEwrong_type_argument(@[stream], strm); + ecl_ferror(ECL_EX_BADARG, @[stream], strm); return (const struct ecl_file_ops *)strm->stream.ops; } @@ -117,7 +132,7 @@ ecl_read_char_noeof(cl_object strm) { ecl_character c = ecl_read_char(strm); if (c == EOF) - FEend_of_file(strm); + ecl_ferror(ECL_EX_EOF, strm, ECL_NIL); return c; } @@ -249,7 +264,7 @@ cl_object si_unread_char(cl_object strm, cl_object c) { cl_env_ptr the_env = ecl_process_env(); - ecl_unread_char(ecl_char_code(c), strm); + ecl_unread_char(_ecl_char_code(c), strm); ecl_return1(the_env, ECL_NIL); } @@ -265,7 +280,7 @@ cl_object si_write_char(cl_object strm, cl_object c) { cl_env_ptr the_env = ecl_process_env(); - ecl_write_char(ecl_char_code(c), strm); + ecl_write_char(_ecl_char_code(c), strm); ecl_return1(the_env, c); } @@ -354,28 +369,25 @@ cl_file_length(cl_object strm) @(return ecl_file_length(strm)); } -@(defun file-position (file_stream &o position) - cl_object output; -@ - if (Null(position)) { - output = ecl_file_position(file_stream); - } else { - if (position == @':start') { - position = ecl_make_fixnum(0); - } else if (position == @':end') { - position = ECL_NIL; - } - output = ecl_file_position_set(file_stream, position); - } - @(return output); -@) - cl_object cl_file_string_length(cl_object stream, cl_object string) { @(return ecl_file_string_length(stream, string)); } +cl_object +si_file_position_get(cl_object strm) +{ + @(return ecl_file_position(strm)); + +} + +cl_object +si_file_position_set(cl_object strm, cl_object position) +{ + @(return ecl_file_position_set(strm, position)); +} + cl_object cl_input_stream_p(cl_object strm) { @@ -406,7 +418,7 @@ cl_open_stream_p(cl_object strm) } #endif unlikely_if (!ECL_ANSI_STREAM_P(strm)) - FEwrong_type_only_arg(@'open-stream-p', strm, @'stream'); + ecl_ferror4(ECL_EX_BADARG_ONLY, @[output-stream-p], strm, @[stream]); @(return (strm->stream.closed ? ECL_NIL : ECL_T)); } @@ -429,11 +441,14 @@ cl_stream_external_format(cl_object strm) else #endif unlikely_if (t != t_stream) - FEwrong_type_only_arg(@[stream-external-format], strm, @[stream]); + ecl_ferror4(ECL_EX_BADARG_ONLY, @[stream-external-format], strm, @[stream]); if (strm->stream.mode == ecl_smm_synonym) { - strm = SYNONYM_STREAM_STREAM(strm); - goto AGAIN; - } + cl_env_ptr the_env = ecl_process_env(); + cl_object sym = SYNONYM_STREAM_SYMBOL(strm); + strm = Null(sym) ? sym : ECL_SYM_VAL(the_env, sym); + if(strm==OBJNULL) + ecl_ferror2(ECL_EX_V_UNBND, sym); + goto AGAIN; } output = strm->stream.format; @(return output); } @@ -467,29 +482,3 @@ si_copy_stream(cl_object in, cl_object out, cl_object wait) ecl_force_output(out); @(return ((c==EOF) ? ECL_T : ECL_NIL)); } - -cl_object -si_file_stream_fd(cl_object s) -{ - cl_object ret; - - unlikely_if (!ECL_FILE_STREAM_P(s)) { - ecl_not_a_file_stream(s); - } - - switch ((enum ecl_smmode)s->stream.mode) { - case ecl_smm_input: - case ecl_smm_output: - case ecl_smm_io: - ret = ecl_make_fixnum(fileno(IO_STREAM_FILE(s))); - break; - case ecl_smm_input_file: - case ecl_smm_output_file: - case ecl_smm_io_file: - ret = ecl_make_fixnum(IO_FILE_DESCRIPTOR(s)); - break; - default: - ecl_internal_error("not a file stream"); - } - @(return ret); -} diff --git a/src/c/streams/strm_common.d b/src/c/streams/strm_common.d index 4f70f9a0a..2fcad02e9 100644 --- a/src/c/streams/strm_common.d +++ b/src/c/streams/strm_common.d @@ -23,52 +23,31 @@ cl_object ecl_not_a_file_stream(cl_object strm) { - cl_error(9, @'simple-type-error', @':format-control', - @"~A is not an file stream", - @':format-arguments', cl_list(1, strm), - @':expected-type', @'file-stream', - @':datum', strm); + ecl_ferror(ECL_EX_BADARG, @[file-stream], strm); } void ecl_not_an_input_stream(cl_object strm) { - cl_error(9, @'simple-type-error', @':format-control', - @"~A is not an input stream", - @':format-arguments', cl_list(1, strm), - @':expected-type', - cl_list(2, @'satisfies', @'input-stream-p'), - @':datum', strm); + ecl_ferror(ECL_EX_UNSATISFIED, @[input-stream-p], strm); } void ecl_not_an_output_stream(cl_object strm) { - cl_error(9, @'simple-type-error', @':format-control', - @"~A is not an output stream", - @':format-arguments', cl_list(1, strm), - @':expected-type', cl_list(2, @'satisfies', @'output-stream-p'), - @':datum', strm); + ecl_ferror(ECL_EX_UNSATISFIED, @[output-stream-p], strm); } static void -not_a_character_stream(cl_object s) +not_a_character_stream(cl_object strm) { - cl_error(9, @'simple-type-error', @':format-control', - @"~A is not a character stream", - @':format-arguments', cl_list(1, s), - @':expected-type', @'character', - @':datum', cl_stream_element_type(s)); + ecl_ferror(ECL_EX_STRM_BADELT, @[character], strm); } static void -not_a_binary_stream(cl_object s) +not_a_binary_stream(cl_object strm) { - cl_error(9, @'simple-type-error', @':format-control', - @"~A is not a binary stream", - @':format-arguments', cl_list(1, s), - @':expected-type', @'integer', - @':datum', cl_stream_element_type(s)); + ecl_ferror(ECL_EX_STRM_BADELT, @[integer], strm); } /********************************************************************** @@ -235,14 +214,14 @@ ecl_unknown_column(cl_object strm) static cl_index closed_stream_read_byte8(cl_object strm, unsigned char *c, cl_index n) { - FEclosed_stream(strm); + ecl_ferror(ECL_EX_STRM_CLOSED, strm, ECL_NIL); return 0; } static cl_index closed_stream_write_byte8(cl_object strm, unsigned char *c, cl_index n) { - FEclosed_stream(strm); + ecl_ferror(ECL_EX_STRM_CLOSED, strm, ECL_NIL); return 0; } @@ -268,34 +247,34 @@ closed_stream_unread_byte(cl_object strm, cl_object byte) static ecl_character closed_stream_read_char(cl_object strm) { - FEclosed_stream(strm); + ecl_ferror(ECL_EX_STRM_CLOSED, strm, ECL_NIL); return 0; } static ecl_character closed_stream_write_char(cl_object strm, ecl_character c) { - FEclosed_stream(strm); + ecl_ferror(ECL_EX_STRM_CLOSED, strm, ECL_NIL); return c; } static void closed_stream_unread_char(cl_object strm, ecl_character c) { - FEclosed_stream(strm); + ecl_ferror(ECL_EX_STRM_CLOSED, strm, ECL_NIL); } static int closed_stream_listen(cl_object strm) { - FEclosed_stream(strm); + ecl_ferror(ECL_EX_STRM_CLOSED, strm, ECL_NIL); return 0; } static void closed_stream_clear_input(cl_object strm) { - FEclosed_stream(strm); + ecl_ferror(ECL_EX_STRM_CLOSED, strm, ECL_NIL); } #define closed_stream_clear_output closed_stream_clear_input @@ -305,7 +284,7 @@ closed_stream_clear_input(cl_object strm) static cl_object closed_stream_length(cl_object strm) { - FEclosed_stream(strm); + ecl_ferror(ECL_EX_STRM_CLOSED, strm, ECL_NIL); } #define closed_stream_get_position closed_stream_length @@ -313,7 +292,7 @@ closed_stream_length(cl_object strm) static cl_object closed_stream_set_position(cl_object strm, cl_object position) { - FEclosed_stream(strm); + ecl_ferror(ECL_EX_STRM_CLOSED, strm, ECL_NIL); } /********************************************************************** @@ -459,4 +438,3 @@ ecl_generic_read_vector(cl_object strm, cl_object data, cl_index start, cl_index } return start; } - diff --git a/src/c/streams/strm_composite.d b/src/c/streams/strm_composite.d index f4aad0056..1a2a0004c 100644 --- a/src/c/streams/strm_composite.d +++ b/src/c/streams/strm_composite.d @@ -194,7 +194,6 @@ const struct ecl_file_ops two_way_ops = { two_way_close }; - cl_object cl_make_two_way_stream(cl_object istrm, cl_object ostrm) { diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 42096da80..9c41012f2 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1191,6 +1191,8 @@ cl_symbols[] = { {SYS_ "EXPAND-DEFMACRO" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "FILE-COLUMN" ECL_FUN("si_file_column", si_file_column, 1) ECL_VAR(SI_ORDINARY, OBJNULL)}, {EXT_ "FILE-KIND" ECL_FUN("si_file_kind", si_file_kind, 2) ECL_VAR(EXT_ORDINARY, OBJNULL)}, +{SYS_ "FILE-POSITION-GET" ECL_FUN("si_file_position_get", si_file_position_get, 1) ECL_VAR(SI_ORDINARY, OBJNULL)}, +{SYS_ "FILE-POSITION-SET" ECL_FUN("si_file_position_set", si_file_position_set, 2) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "FILL-POINTER-SET" ECL_FUN("si_fill_pointer_set", si_fill_pointer_set, 2) ECL_VAR(SI_ORDINARY, OBJNULL)}, {EXT_ "FILE-STREAM-FD" ECL_FUN("si_file_stream_fd", si_file_stream_fd, 1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, {EXT_ "MAKE-STREAM-FROM-FD" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, diff --git a/src/h/external.h b/src/h/external.h index 1dae47bb5..0428cb084 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -568,7 +568,10 @@ extern ECL_API void FEerror(const char *s, int narg, ...) ecl_attr_noreturn; extern ECL_API void FEcannot_open(cl_object fn) ecl_attr_noreturn; extern ECL_API void FEend_of_file(cl_object strm) ecl_attr_noreturn; extern ECL_API void FEclosed_stream(cl_object strm) ecl_attr_noreturn; +extern ECL_API void FEunread_stream(cl_object strm, cl_object twice) ecl_attr_noreturn; extern ECL_API void FEwrong_type_argument(cl_object type, cl_object value) ecl_attr_noreturn; +extern ECL_API void FEwrong_type_pred_arg(cl_object type, cl_object value) ecl_attr_noreturn; +extern ECL_API void FEwrong_type_strm_elt(cl_object type, cl_object value) ecl_attr_noreturn; extern ECL_API void FEwrong_type_only_arg(cl_object function, cl_object type, cl_object value) ecl_attr_noreturn; extern ECL_API void FEwrong_type_nth_arg(cl_object function, cl_narg narg, cl_object value, cl_object type) ecl_attr_noreturn; extern ECL_API void FEwrong_type_key_arg(cl_object function, cl_object keyo, cl_object type, cl_object value) ecl_attr_noreturn; @@ -673,8 +676,20 @@ extern ECL_API cl_object ecl_foreign_data_ref_elt(void *p, enum ecl_ffi_tag type extern ECL_API void ecl_foreign_data_set_elt(void *p, enum ecl_ffi_tag type, cl_object value); /* stream.c */ -cl_object si_unread_byte(cl_object strm, cl_object byte); -cl_object si_peek_byte(cl_object strm, cl_object eof_value); +extern ECL_API cl_object si_write_char(cl_object strm, cl_object c); +extern ECL_API cl_object si_write_byte(cl_object strm, cl_object c); +extern ECL_API cl_object si_read_char(cl_object strm, cl_object eof_value); +extern ECL_API cl_object si_read_byte(cl_object strm, cl_object eof_value); +extern ECL_API cl_object si_peek_char(cl_object strm, cl_object eof_value); +extern ECL_API cl_object si_peek_byte(cl_object strm, cl_object eof_value); +extern ECL_API cl_object si_unread_char(cl_object strm, cl_object c); +extern ECL_API cl_object si_unread_byte(cl_object strm, cl_object byte); + +extern ECL_API cl_object si_listen(cl_object strm); +extern ECL_API cl_object si_clear_input(cl_object strm); +extern ECL_API cl_object si_finish_output(cl_object strm); +extern ECL_API cl_object si_force_output(cl_object strm); +extern ECL_API cl_object si_clear_output(cl_object strm); /* file.c */ @@ -717,6 +732,8 @@ extern ECL_API cl_object cl_file_string_length(cl_object stream, cl_object strin extern ECL_API cl_object si_do_write_sequence(cl_object string, cl_object stream, cl_object start, cl_object end); extern ECL_API cl_object si_do_read_sequence(cl_object string, cl_object stream, cl_object start, cl_object end); extern ECL_API cl_object si_file_column(cl_object strm); +extern ECL_API cl_object si_file_position_get(cl_object strm); +extern ECL_API cl_object si_file_position_set(cl_object strm, cl_object position); extern ECL_API cl_object cl_interactive_stream_p(cl_object strm); #if defined(ECL_MS_WINDOWS_HOST) extern ECL_API cl_object si_windows_codepage_encoding(); @@ -731,6 +748,8 @@ extern ECL_API bool ecl_interactive_stream_p(cl_object strm); extern ECL_API cl_object ecl_open_stream(cl_object fn, enum ecl_smmode smm, cl_object if_exists, cl_object if_does_not_exist, cl_fixnum byte_size, int flags, cl_object external_format); extern ECL_API cl_object ecl_make_string_input_stream(cl_object strng, cl_index istart, cl_index iend); extern ECL_API cl_object ecl_make_string_output_stream(cl_index line_length, int extended); +extern ECL_API cl_index ecl_read_byte8(cl_object strm, unsigned char *c, cl_index n); +extern ECL_API cl_index ecl_write_byte8(cl_object strm, unsigned char *c, cl_index n); extern ECL_API cl_object ecl_read_byte(cl_object strm); extern ECL_API void ecl_write_byte(cl_object byte, cl_object strm); extern ECL_API void ecl_unread_byte(cl_object byte, cl_object strm); diff --git a/src/h/internal.h b/src/h/internal.h index d1eee99a6..dd5e19275 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -411,8 +411,8 @@ cl_object si_finish_output(cl_object strm); cl_object si_force_output(cl_object strm); cl_object si_clear_output(cl_object strm); -#define ecl_unread_error(s) FEerror("Error when unreading to stream ~D", 1, s) -#define ecl_unread_twice(s) FEerror("Unread twice twice to stream ~D", 1, s) +#define ecl_unread_error(s) ecl_ferror(ECL_EX_STRM_UNREAD, strm, ECL_NIL); +#define ecl_unread_twice(s) ecl_ferror(ECL_EX_STRM_UNREAD, strm, ECL_T); /* streams/strm_common.d */ cl_object ecl_not_a_file_stream(cl_object strm); diff --git a/src/h/object.h b/src/h/object.h index 1a07843a1..58e5b0940 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -578,6 +578,7 @@ enum ecl_smmode { /* stream mode */ ecl_smm_string_input, /* string input */ ecl_smm_string_output, /* string output */ ecl_smm_probe, /* probe (only used in open_stream()) */ + ecl_smm_other, /* custom stream implementation */ #if defined(ECL_WSOCK) ecl_smm_input_wsock, /* input socket (Win32) */ ecl_smm_output_wsock, /* output socket (Win32) */ @@ -965,6 +966,16 @@ typedef enum { ECL_EX_CS_OVR, /* stack overflow */ ECL_EX_FRS_OVR, /* stack overflow */ ECL_EX_BDS_OVR, /* stack overflow */ + ECL_EX_BADARG, /* wrong type of argument */ + ECL_EX_BADARG_ONLY, /* wrong type of the only argument */ + ECL_EX_BADARG_NTH, /* wrong type of the nth argument */ + ECL_EX_UNSATISFIED, /* wrong type of argument (predicate) */ + ECL_EX_EOF, /* end of file */ + ECL_EX_NIY, /* not implemented yet */ + ECL_EX_NAO, /* not applicable operation */ + ECL_EX_STRM_BADELT, /* invalid stream element type */ + ECL_EX_STRM_CLOSED, /* the stream is closed */ + ECL_EX_STRM_UNREAD, /* error while unreading into the stream */ /* Kludges for the bytecodes VM */ ECL_EX_VM_BADARG_EXCD, ECL_EX_VM_BADARG_UNKK,