mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-06 17:30:41 -08:00
Fixes in various reader macros (#*, #(,#C)). Stream mode smm_closed disappears and closing of files preserves the original type of stream. Implemented METHOD-COMBINATION-ERROR, INVALID-METHOD-ERROR, option :ARGUMENT-PRECEDENCE-ORDER. In loop, iteration statements can now only appear before body statements, otherwise an error is signaled. A DEFTYPE form optional arguments have default value *
This commit is contained in:
jjgarcia
parent
01770061ff
commit
dd39b19a32
25 changed files with 318 additions and 235 deletions
|
|
@ -18,6 +18,16 @@ ECL 1.0
|
|||
|
||||
- The routines in the pretty printer now check the type of the arguments.
|
||||
|
||||
- The parser for #* did not accept #0* and also did not signal errors when
|
||||
invalid characters were found.
|
||||
|
||||
- The parser for #( did not accept empty vectors.
|
||||
|
||||
- The parser for #C did not accept whitespaces between #\C and the list.
|
||||
|
||||
- The reader macros for sharp-single-quote (#') and single-quote (')
|
||||
did not pay attention to the end of file condition.
|
||||
|
||||
* Visible changes:
|
||||
|
||||
- SI:MKSTEMP now accepts and returns pathnames.
|
||||
|
|
@ -35,6 +45,13 @@ ECL 1.0
|
|||
- When parsing a physical pathname, version is NIL unless the pathname
|
||||
has a name or a type components, in which case version is :NEWEST.
|
||||
|
||||
- The stream mode smm_closed disappears. Instead we add a flag called
|
||||
stream.closed. Besides this fulfills the fact that CLOSE cannot change
|
||||
the class of the stream
|
||||
|
||||
- ENSURE-GENERIC-FUNCTION, DEFGENERIC and DEFMETHOD now can operate
|
||||
on functions which are being traced.
|
||||
|
||||
* Internals:
|
||||
|
||||
- The compiler now uses a more detailed tree to represent the code, keeping
|
||||
|
|
@ -143,6 +160,27 @@ ECL 1.0
|
|||
Now the keyword arguments of the applicable methods are considered to
|
||||
be valid initargs (ANSI 7.1.2)
|
||||
|
||||
- It is now possible to change the class of a generic function using
|
||||
DEFGENERIC or ENSURE-GENERIC-FUNCTION(-USING-CLASS).
|
||||
|
||||
- Implemented METHOD-COMBINATION-ERROR and INVALID-METHOD-ERROR.
|
||||
|
||||
- ECL now uses the character trait "invalid" (ANSI 2.1.4.2).
|
||||
|
||||
- (LOOP FOR NIL FROM ...) is a valid statement and the presence of NIL
|
||||
only denotes that we ignore the value.
|
||||
|
||||
- In LOOP, the order of statements in the body is now preserved. Formerly
|
||||
WHILE and RETURN clauses were not thought to be part of the loop body.
|
||||
Furthermore, FOR-AS clauses cannot appear after a main clause, such as
|
||||
WHILE, WHEN, IF, DO, COLLECT, etc...
|
||||
|
||||
- Option sorting of methods now takes into account the generic function
|
||||
option :ARGUMENT-PRECEDENCE-ORDER.
|
||||
|
||||
- The default value of optional arguments in a DEFTYPE form "defaults" to '*
|
||||
(ANSI 3.4.8).
|
||||
|
||||
* MOP compliance:
|
||||
|
||||
- ADD-METHOD is now a generic function and implements most of the protocol in
|
||||
|
|
|
|||
|
|
@ -315,7 +315,7 @@ ONCE_MORE:
|
|||
break;
|
||||
#endif /* CLOS */
|
||||
case t_stream:
|
||||
obj->stream.mode = (short)smm_closed;
|
||||
obj->stream.mode = (short)smm_broadcast;
|
||||
obj->stream.file = NULL;
|
||||
obj->stream.object0 = OBJNULL;
|
||||
obj->stream.object1 = OBJNULL;
|
||||
|
|
|
|||
|
|
@ -51,6 +51,9 @@ main(int argc, char **args)
|
|||
/* This should be always the first call */
|
||||
cl_boot(argc, args);
|
||||
|
||||
#ifdef ECL_CMU_FORMAT
|
||||
SYM_VAL(@'*load-verbose*') = Cnil;
|
||||
#endif
|
||||
SYM_VAL(@'*package*') = cl_core.system_package;
|
||||
SYM_VAL(@'*features*') = CONS(make_keyword("ECL-MIN"), SYM_VAL(@'*features*'));
|
||||
#ifdef CLOS
|
||||
|
|
|
|||
122
src/c/file.d
122
src/c/file.d
|
|
@ -62,10 +62,6 @@ BEGIN:
|
|||
if (type_of(strm) != t_stream)
|
||||
FEtype_error_stream(strm);
|
||||
switch ((enum ecl_smmode)strm->stream.mode) {
|
||||
case smm_closed:
|
||||
FEclosed_stream(strm);
|
||||
break;
|
||||
|
||||
case smm_io:
|
||||
case smm_input:
|
||||
#ifdef _MSC_VER
|
||||
|
|
@ -113,10 +109,6 @@ BEGIN:
|
|||
if (type_of(strm) != t_stream)
|
||||
FEtype_error_stream(strm);
|
||||
switch ((enum ecl_smmode)strm->stream.mode) {
|
||||
case smm_closed:
|
||||
FEclosed_stream(strm);
|
||||
return(FALSE);
|
||||
|
||||
case smm_input:
|
||||
#ifdef _MSC_VER
|
||||
case smm_input_wsock:
|
||||
|
|
@ -163,11 +155,11 @@ BEGIN:
|
|||
if (type_of(strm) == t_instance)
|
||||
funcall(2, @'ext::stream-input-p', strm);
|
||||
#endif
|
||||
if (type_of(strm) != t_stream)
|
||||
if (type_of(strm) != t_stream)
|
||||
FEtype_error_stream(strm);
|
||||
switch ((enum ecl_smmode)strm->stream.mode) {
|
||||
case smm_closed:
|
||||
if (strm->stream.closed)
|
||||
FEclosed_stream(strm);
|
||||
switch ((enum ecl_smmode)strm->stream.mode) {
|
||||
case smm_input:
|
||||
case smm_output:
|
||||
#ifdef _MSC_VER
|
||||
|
|
@ -278,7 +270,7 @@ io_error(cl_object strm)
|
|||
static void
|
||||
wrong_file_handler(cl_object strm)
|
||||
{
|
||||
FEerror("Internal error: closed stream ~S without smm_mode flag.", 1, strm);
|
||||
FEerror("Internal error: stream ~S has no valid C file handler.", 1, strm);
|
||||
}
|
||||
|
||||
#ifdef _MSC_VER
|
||||
|
|
@ -433,6 +425,7 @@ open_stream(cl_object fn, enum ecl_smmode smm, cl_object if_exists,
|
|||
}
|
||||
x = cl_alloc_object(t_stream);
|
||||
x->stream.mode = (short)smm;
|
||||
x->stream.closed = 0;
|
||||
x->stream.file = fp;
|
||||
x->stream.char_stream_p = char_stream_p;
|
||||
/* Michael, touch this to reactivate support for odd bit sizes! */
|
||||
|
|
@ -493,13 +486,11 @@ close_stream(cl_object strm, bool abort_flag) /* Not used now! */
|
|||
#endif
|
||||
if (type_of(strm) != t_stream)
|
||||
FEtype_error_stream(strm);
|
||||
/* It is permissible to close a closed file */
|
||||
if (strm->stream.closed)
|
||||
return;
|
||||
fp = strm->stream.file;
|
||||
switch ((enum ecl_smmode)strm->stream.mode) {
|
||||
case smm_closed:
|
||||
/* It is permissible to close a closed stream, although the output
|
||||
is unspecified in those cases. */
|
||||
break;
|
||||
|
||||
case smm_output:
|
||||
if (fp == stdout)
|
||||
FEerror("Cannot close the standard output.", 0);
|
||||
|
|
@ -560,9 +551,8 @@ close_stream(cl_object strm, bool abort_flag) /* Not used now! */
|
|||
default:
|
||||
error("illegal stream mode");
|
||||
}
|
||||
strm->stream.mode = smm_closed;
|
||||
strm->stream.closed = 1;
|
||||
strm->stream.file = NULL;
|
||||
strm->stream.object0 = OBJNULL;
|
||||
}
|
||||
|
||||
cl_object
|
||||
|
|
@ -572,6 +562,7 @@ make_two_way_stream(cl_object istrm, cl_object ostrm)
|
|||
|
||||
strm = cl_alloc_object(t_stream);
|
||||
strm->stream.mode = (short)smm_two_way;
|
||||
strm->stream.closed = 0;
|
||||
strm->stream.file = NULL;
|
||||
strm->stream.object0 = istrm;
|
||||
strm->stream.object1 = ostrm;
|
||||
|
|
@ -586,6 +577,7 @@ make_string_input_stream(cl_object strng, cl_index istart, cl_index iend)
|
|||
|
||||
strm = cl_alloc_object(t_stream);
|
||||
strm->stream.mode = (short)smm_string_input;
|
||||
strm->stream.closed = 0;
|
||||
strm->stream.file = NULL;
|
||||
strm->stream.object0 = strng;
|
||||
strm->stream.object1 = OBJNULL;
|
||||
|
|
@ -613,6 +605,7 @@ make_string_output_stream_from_string(cl_object s)
|
|||
FEerror("~S is not a string with a fill-pointer.", 1, s);
|
||||
strm = cl_alloc_object(t_stream);
|
||||
strm->stream.mode = (short)smm_string_output;
|
||||
strm->stream.closed = 0;
|
||||
strm->stream.file = NULL;
|
||||
strm->stream.object0 = s;
|
||||
strm->stream.object1 = OBJNULL;
|
||||
|
|
@ -699,10 +692,9 @@ BEGIN:
|
|||
#endif
|
||||
if (type_of(strm) != t_stream)
|
||||
FEtype_error_stream(strm);
|
||||
switch ((enum ecl_smmode)strm->stream.mode) {
|
||||
case smm_closed:
|
||||
if (strm->stream.closed)
|
||||
FEclosed_stream(strm);
|
||||
break;
|
||||
switch ((enum ecl_smmode)strm->stream.mode) {
|
||||
case smm_output:
|
||||
case smm_io:
|
||||
#ifdef _MSC_VER
|
||||
|
|
@ -904,10 +896,9 @@ BEGIN:
|
|||
#endif
|
||||
if (type_of(strm) != t_stream)
|
||||
FEtype_error_stream(strm);
|
||||
switch ((enum ecl_smmode)strm->stream.mode) {
|
||||
case smm_closed:
|
||||
if (strm->stream.closed)
|
||||
FEclosed_stream(strm);
|
||||
break;
|
||||
switch ((enum ecl_smmode)strm->stream.mode) {
|
||||
case smm_input:
|
||||
case smm_io:
|
||||
case smm_string_input:
|
||||
|
|
@ -1042,11 +1033,9 @@ BEGIN:
|
|||
#endif
|
||||
if (type_of(strm) != t_stream)
|
||||
FEtype_error_stream(strm);
|
||||
switch ((enum ecl_smmode)strm->stream.mode) {
|
||||
case smm_closed:
|
||||
if (strm->stream.closed)
|
||||
FEclosed_stream(strm);
|
||||
break;
|
||||
|
||||
switch ((enum ecl_smmode)strm->stream.mode) {
|
||||
case smm_input:
|
||||
case smm_io: {
|
||||
FILE *fp = strm->stream.file;
|
||||
|
|
@ -1158,12 +1147,10 @@ BEGIN:
|
|||
#endif
|
||||
if (type_of(strm) != t_stream)
|
||||
FEtype_error_stream(strm);
|
||||
if (strm->stream.closed)
|
||||
FEclosed_stream(strm);
|
||||
fp = strm->stream.file;
|
||||
switch ((enum ecl_smmode)strm->stream.mode) {
|
||||
case smm_closed:
|
||||
FEclosed_stream(strm);
|
||||
break;
|
||||
|
||||
case smm_input:
|
||||
case smm_io:
|
||||
if (!strm->stream.char_stream_p)
|
||||
|
|
@ -1252,12 +1239,10 @@ BEGIN:
|
|||
#endif
|
||||
if (type_of(strm) != t_stream)
|
||||
FEtype_error_stream(strm);
|
||||
if (strm->stream.closed)
|
||||
FEclosed_stream(strm);
|
||||
fp = strm->stream.file;
|
||||
switch ((enum ecl_smmode)strm->stream.mode) {
|
||||
case smm_closed:
|
||||
FEclosed_stream(strm);
|
||||
break;
|
||||
|
||||
case smm_input:
|
||||
case smm_io:
|
||||
if (!strm->stream.char_stream_p)
|
||||
|
|
@ -1332,12 +1317,10 @@ BEGIN:
|
|||
#endif
|
||||
if (type_of(strm) != t_stream)
|
||||
FEtype_error_stream(strm);
|
||||
if (strm->stream.closed)
|
||||
FEclosed_stream(strm);
|
||||
fp = strm->stream.file;
|
||||
switch ((enum ecl_smmode)strm->stream.mode) {
|
||||
case smm_closed:
|
||||
FEclosed_stream(strm);
|
||||
break;
|
||||
|
||||
case smm_output:
|
||||
case smm_io:
|
||||
if (!strm->stream.char_stream_p)
|
||||
|
|
@ -1602,11 +1585,9 @@ BEGIN:
|
|||
#endif
|
||||
if (type_of(strm) != t_stream)
|
||||
FEtype_error_stream(strm);
|
||||
switch ((enum ecl_smmode)strm->stream.mode) {
|
||||
case smm_closed:
|
||||
if (strm->stream.closed)
|
||||
FEclosed_stream(strm);
|
||||
break;
|
||||
|
||||
switch ((enum ecl_smmode)strm->stream.mode) {
|
||||
case smm_output:
|
||||
case smm_io: {
|
||||
FILE *fp = strm->stream.file;
|
||||
|
|
@ -1672,12 +1653,10 @@ BEGIN:
|
|||
#endif
|
||||
if (type_of(strm) != t_stream)
|
||||
FEtype_error_stream(strm);
|
||||
if (strm->stream.closed)
|
||||
FEclosed_stream(strm);
|
||||
fp = strm->stream.file;
|
||||
switch ((enum ecl_smmode)strm->stream.mode) {
|
||||
case smm_closed:
|
||||
FEclosed_stream(strm);
|
||||
break;
|
||||
|
||||
case smm_input:
|
||||
if (fp == NULL)
|
||||
wrong_file_handler(strm);
|
||||
|
|
@ -1737,12 +1716,10 @@ BEGIN:
|
|||
#endif
|
||||
if (type_of(strm) != t_stream)
|
||||
FEtype_error_stream(strm);
|
||||
if (strm->stream.closed)
|
||||
FEclosed_stream(strm);
|
||||
fp = strm->stream.file;
|
||||
switch ((enum ecl_smmode)strm->stream.mode) {
|
||||
case smm_closed:
|
||||
FEclosed_stream(strm);
|
||||
break;
|
||||
|
||||
case smm_output:
|
||||
#if 0
|
||||
if (fp == NULL)
|
||||
|
|
@ -1835,11 +1812,9 @@ BEGIN:
|
|||
#endif
|
||||
if (type_of(strm) != t_stream)
|
||||
FEtype_error_stream(strm);
|
||||
switch ((enum ecl_smmode)strm->stream.mode) {
|
||||
case smm_closed:
|
||||
if (strm->stream.closed)
|
||||
FEclosed_stream(strm);
|
||||
return ECL_LISTEN_EOF;
|
||||
|
||||
switch ((enum ecl_smmode)strm->stream.mode) {
|
||||
case smm_input:
|
||||
case smm_io:
|
||||
fp = strm->stream.file;
|
||||
|
|
@ -1919,11 +1894,9 @@ BEGIN:
|
|||
#endif
|
||||
if (type_of(strm) != t_stream)
|
||||
FEtype_error_stream(strm);
|
||||
switch ((enum ecl_smmode)strm->stream.mode) {
|
||||
case smm_closed:
|
||||
if (strm->stream.closed)
|
||||
FEclosed_stream(strm);
|
||||
return Cnil;
|
||||
|
||||
switch ((enum ecl_smmode)strm->stream.mode) {
|
||||
case smm_output:
|
||||
case smm_io:
|
||||
case smm_input: {
|
||||
|
|
@ -2004,11 +1977,9 @@ BEGIN:
|
|||
#endif
|
||||
if (type_of(strm) != t_stream)
|
||||
FEtype_error_stream(strm);
|
||||
switch ((enum ecl_smmode)strm->stream.mode) {
|
||||
case smm_closed:
|
||||
if (strm->stream.closed)
|
||||
FEclosed_stream(strm);
|
||||
return Cnil;
|
||||
|
||||
switch ((enum ecl_smmode)strm->stream.mode) {
|
||||
case smm_input:
|
||||
case smm_output:
|
||||
case smm_io: {
|
||||
|
|
@ -2110,11 +2081,9 @@ BEGIN:
|
|||
#endif
|
||||
if (type_of(strm) != t_stream)
|
||||
FEtype_error_stream(strm);
|
||||
switch ((enum ecl_smmode)strm->stream.mode) {
|
||||
case smm_closed:
|
||||
if (strm->stream.closed)
|
||||
FEclosed_stream(strm);
|
||||
output = Cnil;
|
||||
break;
|
||||
switch ((enum ecl_smmode)strm->stream.mode) {
|
||||
case smm_input:
|
||||
case smm_output:
|
||||
case smm_io: {
|
||||
|
|
@ -2185,11 +2154,9 @@ BEGIN:
|
|||
#endif
|
||||
if (type_of(strm) != t_stream)
|
||||
FEtype_error_stream(strm);
|
||||
switch ((enum ecl_smmode)strm->stream.mode) {
|
||||
case smm_closed:
|
||||
if (strm->stream.closed)
|
||||
FEclosed_stream(strm);
|
||||
return 0;
|
||||
|
||||
switch ((enum ecl_smmode)strm->stream.mode) {
|
||||
case smm_output:
|
||||
#ifdef _MSC_VER
|
||||
case smm_output_wsock:
|
||||
|
|
@ -2234,6 +2201,7 @@ cl_make_synonym_stream(cl_object sym)
|
|||
assert_type_symbol(sym);
|
||||
x = cl_alloc_object(t_stream);
|
||||
x->stream.mode = (short)smm_synonym;
|
||||
x->stream.closed = 0;
|
||||
x->stream.file = NULL;
|
||||
x->stream.object0 = sym;
|
||||
x->stream.object1 = OBJNULL;
|
||||
|
|
@ -2262,6 +2230,7 @@ cl_synonym_stream_symbol(cl_object strm)
|
|||
}
|
||||
x = cl_alloc_object(t_stream);
|
||||
x->stream.mode = (short)smm_broadcast;
|
||||
x->stream.closed = 0;
|
||||
x->stream.file = NULL;
|
||||
x->stream.object0 = cl_nreverse(streams);
|
||||
x->stream.object1 = OBJNULL;
|
||||
|
|
@ -2290,6 +2259,7 @@ cl_broadcast_stream_streams(cl_object strm)
|
|||
}
|
||||
x = cl_alloc_object(t_stream);
|
||||
x->stream.mode = (short)smm_concatenated;
|
||||
x->stream.closed = 0;
|
||||
x->stream.file = NULL;
|
||||
x->stream.object0 = cl_nreverse(streams);
|
||||
x->stream.object1 = OBJNULL;
|
||||
|
|
@ -2596,7 +2566,7 @@ cl_open_stream_p(cl_object strm)
|
|||
when #'close has been applied on it */
|
||||
if (type_of(strm) != t_stream)
|
||||
FEwrong_type_argument(@'stream', strm);
|
||||
@(return (strm->stream.mode != smm_closed ? Ct : Cnil))
|
||||
@(return (strm->stream.closed ? Cnil : Ct))
|
||||
}
|
||||
|
||||
cl_object
|
||||
|
|
@ -2686,6 +2656,7 @@ ecl_make_stream_from_fd(cl_object fname, int fd, enum ecl_smmode smm)
|
|||
|
||||
stream = cl_alloc_object(t_stream);
|
||||
stream->stream.mode = (short)smm;
|
||||
stream->stream.closed = 0;
|
||||
stream->stream.file = fp;
|
||||
stream->stream.object0 = @'base-char';
|
||||
stream->stream.object1 = fname; /* not really used */
|
||||
|
|
@ -2711,6 +2682,7 @@ init_file(void)
|
|||
|
||||
standard_input = cl_alloc_object(t_stream);
|
||||
standard_input->stream.mode = (short)smm_input;
|
||||
standard_input->stream.closed = 0;
|
||||
standard_input->stream.file = stdin;
|
||||
standard_input->stream.object0 = @'base-char';
|
||||
standard_input->stream.object1 = make_constant_string("stdin");
|
||||
|
|
@ -2722,6 +2694,7 @@ init_file(void)
|
|||
|
||||
standard_output = cl_alloc_object(t_stream);
|
||||
standard_output->stream.mode = (short)smm_output;
|
||||
standard_output->stream.closed = 0;
|
||||
standard_output->stream.file = stdout;
|
||||
standard_output->stream.object0 = @'base-char';
|
||||
standard_output->stream.object1= make_constant_string("stdout");
|
||||
|
|
@ -2738,6 +2711,7 @@ init_file(void)
|
|||
|
||||
x = cl_alloc_object(t_stream);
|
||||
x->stream.mode = (short)smm_synonym;
|
||||
x->stream.closed = 0;
|
||||
x->stream.file = NULL;
|
||||
x->stream.object0 = @'*terminal-io*';
|
||||
x->stream.object1 = OBJNULL;
|
||||
|
|
|
|||
|
|
@ -262,10 +262,6 @@ BEGIN:
|
|||
|
||||
case t_stream:
|
||||
switch ((enum ecl_smmode)x->stream.mode) {
|
||||
case smm_closed:
|
||||
/* Rest of fields are NULL */
|
||||
mark_next(x->stream.object1);
|
||||
break;
|
||||
case smm_input:
|
||||
case smm_output:
|
||||
case smm_io:
|
||||
|
|
|
|||
28
src/c/gfun.d
28
src/c/gfun.d
|
|
@ -109,28 +109,28 @@ compute_method(cl_narg narg, cl_object gf, cl_object *args)
|
|||
FEerror("compute_method: Too many arguments, limited to ~A.", 1, MAKE_FIXNUM(ARGTYPE_MAX));
|
||||
#endif
|
||||
|
||||
for (i = 0, spec_no = 0; spec_how_list != Cnil; i++) {
|
||||
for (spec_no = 0; spec_how_list != Cnil;) {
|
||||
cl_object spec_how = CAR(spec_how_list);
|
||||
if (spec_how != Cnil) {
|
||||
if (i >= narg)
|
||||
FEwrong_num_arguments(gf);
|
||||
argtype[spec_no++] =
|
||||
(ATOM(spec_how) ||
|
||||
Null(memql(args[i], spec_how))) ?
|
||||
cl_class_of(args[i]) :
|
||||
args[i];
|
||||
}
|
||||
cl_object spec_type = CAR(spec_how);
|
||||
int spec_position = fix(CDR(spec_how));
|
||||
if (spec_position >= narg)
|
||||
FEwrong_num_arguments(gf);
|
||||
argtype[spec_no++] =
|
||||
(ATOM(spec_type) ||
|
||||
Null(memql(args[spec_position], spec_type))) ?
|
||||
cl_class_of(args[spec_position]) :
|
||||
args[spec_position];
|
||||
spec_how_list = CDR(spec_how_list);
|
||||
}
|
||||
|
||||
e = get_meth_hash(argtype, spec_no, table);
|
||||
|
||||
if (e->key == OBJNULL) {
|
||||
if (e->key == OBJNULL) {
|
||||
/* method not cached */
|
||||
cl_object methods, arglist = Cnil;
|
||||
i = narg;
|
||||
while (i-- > 0)
|
||||
cl_object methods, arglist;
|
||||
for (i = narg, arglist = Cnil; i-- > 0; ) {
|
||||
arglist = CONS(args[i], arglist);
|
||||
}
|
||||
methods = funcall(3, @'compute-applicable-methods', gf,
|
||||
arglist);
|
||||
func = funcall(4, @'si::compute-effective-method', gf,
|
||||
|
|
|
|||
|
|
@ -567,7 +567,6 @@ L:
|
|||
|
||||
case t_stream:
|
||||
switch ((enum ecl_smmode)x->stream.mode) {
|
||||
case smm_closed:
|
||||
case smm_input:
|
||||
case smm_output:
|
||||
case smm_probe:
|
||||
|
|
|
|||
|
|
@ -1217,71 +1217,67 @@ si_write_ugly_object(cl_object x, cl_object stream)
|
|||
|
||||
case t_stream:
|
||||
if (ecl_print_readably()) FEprint_not_readable(x);
|
||||
write_str(x->stream.closed? "#<closed " : "#<", stream);
|
||||
switch ((enum ecl_smmode)x->stream.mode) {
|
||||
case smm_closed:
|
||||
write_str("#<closed stream ", stream);
|
||||
si_write_ugly_object(x->stream.object1, stream);
|
||||
break;
|
||||
|
||||
case smm_input:
|
||||
write_str("#<input stream ", stream);
|
||||
write_str("input stream ", stream);
|
||||
si_write_ugly_object(x->stream.object1, stream);
|
||||
break;
|
||||
|
||||
case smm_output:
|
||||
write_str("#<output stream ", stream);
|
||||
write_str("output stream ", stream);
|
||||
si_write_ugly_object(x->stream.object1, stream);
|
||||
break;
|
||||
|
||||
#ifdef _MSC_VER
|
||||
case smm_input_wsock:
|
||||
write_str("#<input win32 socket stream ", stream);
|
||||
write_str("input win32 socket stream ", stream);
|
||||
si_write_ugly_object(x->stream.object1, stream);
|
||||
break;
|
||||
|
||||
case smm_output_wsock:
|
||||
write_str("#<output win32 socket stream ", stream);
|
||||
write_str("output win32 socket stream ", stream);
|
||||
si_write_ugly_object(x->stream.object1, stream);
|
||||
break;
|
||||
#endif
|
||||
|
||||
case smm_io:
|
||||
write_str("#<io stream ", stream);
|
||||
write_str("io stream ", stream);
|
||||
si_write_ugly_object(x->stream.object1, stream);
|
||||
break;
|
||||
|
||||
case smm_probe:
|
||||
write_str("#<probe stream ", stream);
|
||||
write_str("probe stream ", stream);
|
||||
si_write_ugly_object(x->stream.object1, stream);
|
||||
break;
|
||||
|
||||
case smm_synonym:
|
||||
write_str("#<synonym stream to ", stream);
|
||||
write_str("synonym stream to ", stream);
|
||||
si_write_ugly_object(x->stream.object0, stream);
|
||||
break;
|
||||
|
||||
case smm_broadcast:
|
||||
write_str("#<broadcast stream ", stream);
|
||||
write_str("broadcast stream ", stream);
|
||||
write_addr(x, stream);
|
||||
break;
|
||||
|
||||
case smm_concatenated:
|
||||
write_str("#<concatenated stream ", stream);
|
||||
write_str("concatenated stream ", stream);
|
||||
write_addr(x, stream);
|
||||
break;
|
||||
|
||||
case smm_two_way:
|
||||
write_str("#<two-way stream ", stream);
|
||||
write_str("two-way stream ", stream);
|
||||
write_addr(x, stream);
|
||||
break;
|
||||
|
||||
case smm_echo:
|
||||
write_str("#<echo stream ", stream);
|
||||
write_str("echo stream ", stream);
|
||||
write_addr(x, stream);
|
||||
break;
|
||||
|
||||
case smm_string_input:
|
||||
write_str("#<string-input stream from \"", stream);
|
||||
write_str("string-input stream from \"", stream);
|
||||
y = x->stream.object0;
|
||||
k = y->string.fillp;
|
||||
for (ndx = 0; ndx < k && ndx < 16; ndx++)
|
||||
|
|
@ -1292,7 +1288,7 @@ si_write_ugly_object(cl_object x, cl_object stream)
|
|||
break;
|
||||
|
||||
case smm_string_output:
|
||||
write_str("#<string-output stream ", stream);
|
||||
write_str("string-output stream ", stream);
|
||||
write_addr(x, stream);
|
||||
break;
|
||||
|
||||
|
|
|
|||
90
src/c/read.d
90
src/c/read.d
|
|
@ -106,8 +106,10 @@ read_object_with_delimiter(cl_object in, int delimiter)
|
|||
BEGIN:
|
||||
do {
|
||||
c = ecl_read_char(in);
|
||||
if (c == EOF || c == delimiter)
|
||||
return(OBJNULL);
|
||||
if (c == delimiter)
|
||||
return OBJNULL;
|
||||
if (c == EOF)
|
||||
FEend_of_file(in);
|
||||
a = cat(rtbl, c);
|
||||
} while (a == cat_whitespace);
|
||||
if (a == cat_terminating || a == cat_non_terminating) {
|
||||
|
|
@ -213,6 +215,9 @@ BEGIN:
|
|||
ecl_unread_char(c, in);
|
||||
break;
|
||||
}
|
||||
if (ecl_invalid_character_p(c)) {
|
||||
FEreader_error("Found invalid character ~:C", in, 1, CODE_CHAR(c));
|
||||
}
|
||||
if (read_case != ecl_case_preserve) {
|
||||
if (isupper(c)) {
|
||||
upcase++;
|
||||
|
|
@ -565,7 +570,10 @@ dispatch_reader_fun(cl_object in, cl_object dc)
|
|||
static cl_object
|
||||
single_quote_reader(cl_object in, cl_object c)
|
||||
{
|
||||
@(return CONS(@'quote', CONS(read_object(in), Cnil)))
|
||||
c = read_object(in);
|
||||
if (c == OBJNULL)
|
||||
FEend_of_file(in);
|
||||
@(return cl_list(2, @'quote', c))
|
||||
}
|
||||
|
||||
static cl_object
|
||||
|
|
@ -600,17 +608,14 @@ sharp_C_reader(cl_object in, cl_object c, cl_object d)
|
|||
|
||||
if (d != Cnil && !read_suppress)
|
||||
extra_argument('C', in, d);
|
||||
if (ecl_read_char_noeof(in) != '(')
|
||||
FEreader_error("A left parenthesis is expected.", in, 0);
|
||||
real = read_object_with_delimiter(in, ')');
|
||||
if (real == OBJNULL)
|
||||
FEreader_error("No real part.", in, 0);
|
||||
imag = read_object_with_delimiter(in, ')');
|
||||
if (imag == OBJNULL)
|
||||
FEreader_error("No imaginary part.", in, 0);
|
||||
x = read_object_with_delimiter(in, ')');
|
||||
if (x != OBJNULL)
|
||||
FEreader_error("A right parenthesis is expected.", in, 0);
|
||||
x = read_object(in);
|
||||
if (x == OBJNULL)
|
||||
FEend_of_file(in);
|
||||
if (type_of(x) != t_cons || length(x) != 2)
|
||||
FEreader_error("Reader macro #C should be followed by a list",
|
||||
in, 0);
|
||||
real = CAR(x);
|
||||
imag = CADR(x);
|
||||
if (read_suppress)
|
||||
@(return Cnil);
|
||||
/* INV: make_complex() checks its types. When reading circular
|
||||
|
|
@ -672,7 +677,10 @@ sharp_single_quote_reader(cl_object in, cl_object c, cl_object d)
|
|||
{
|
||||
if(d != Cnil && !read_suppress)
|
||||
extra_argument('#', in, d);
|
||||
@(return CONS(@'function', CONS(read_object(in), Cnil)))
|
||||
c = read_object(in);
|
||||
if (c == OBJNULL)
|
||||
FEend_of_file(in);
|
||||
@(return cl_list(2, @'function', c))
|
||||
}
|
||||
|
||||
#define QUOTE 1
|
||||
|
|
@ -728,9 +736,9 @@ L:
|
|||
if (fixed_size) {
|
||||
if (dimcount > dim)
|
||||
FEreader_error("Too many elements in #(...).", in, 0);
|
||||
if (dimcount == 0)
|
||||
if (dim && dimcount == 0)
|
||||
FEreader_error("Cannot fill the vector #().", in, 0);
|
||||
else last = cl_env.stack_top[-1];
|
||||
last = cl_env.stack_top[-1];
|
||||
} else
|
||||
dim = dimcount;
|
||||
x = cl_alloc_simple_vector(dim, aet_object);
|
||||
|
|
@ -745,9 +753,11 @@ static cl_object
|
|||
sharp_asterisk_reader(cl_object in, cl_object c, cl_object d)
|
||||
{
|
||||
bool fixed_size;
|
||||
cl_object last, elt, x;
|
||||
cl_index dim, dimcount, i;
|
||||
cl_index sp = cl_stack_index();
|
||||
cl_object last, elt, x;
|
||||
cl_object rtbl = ecl_current_readtable();
|
||||
enum ecl_chattrib a;
|
||||
|
||||
if (read_suppress) {
|
||||
read_constituent(in);
|
||||
|
|
@ -763,17 +773,23 @@ sharp_asterisk_reader(cl_object in, cl_object c, cl_object d)
|
|||
int x = ecl_read_char(in);
|
||||
if (x == EOF)
|
||||
break;
|
||||
if (x != '0' && x != '1') {
|
||||
a = cat(rtbl, x);
|
||||
if (a == cat_terminating || a == cat_whitespace) {
|
||||
ecl_unread_char(x, in);
|
||||
break;
|
||||
} else {
|
||||
cl_stack_push(MAKE_FIXNUM(x == '1'));
|
||||
}
|
||||
if (a == cat_single_escape || a == cat_multiple_escape ||
|
||||
(x != '0' && x != '1'))
|
||||
{
|
||||
FEreader_error("Character ~:C is not allowed after #*",
|
||||
in, 1, CODE_CHAR(x));
|
||||
}
|
||||
cl_stack_push(MAKE_FIXNUM(x == '1'));
|
||||
}
|
||||
if (fixed_size) {
|
||||
if (dimcount > dim)
|
||||
FEreader_error("Too many elements in #*....", in, 0);
|
||||
if (dimcount == 0)
|
||||
if (dim && (dimcount == 0))
|
||||
FEreader_error("Cannot fill the bit-vector #*.", in, 0);
|
||||
else last = cl_env.stack_top[-1];
|
||||
} else {
|
||||
|
|
@ -848,13 +864,17 @@ M:
|
|||
static cl_object
|
||||
sharp_dot_reader(cl_object in, cl_object c, cl_object d)
|
||||
{
|
||||
if(d != Cnil && !read_suppress)
|
||||
if (d != Cnil && !read_suppress)
|
||||
extra_argument('.', in, d);
|
||||
in = read_object(in);
|
||||
c = read_object(in);
|
||||
if (c == OBJNULL)
|
||||
FEend_of_file(in);
|
||||
if (read_suppress)
|
||||
@(return Cnil)
|
||||
in = si_eval_with_env(1, in);
|
||||
@(return in)
|
||||
@(return Cnil);
|
||||
if (symbol_value(@'*read-eval*') == Cnil)
|
||||
FEreader_error("Cannot evaluate the form #.~A", 1, c);
|
||||
c = si_eval_with_env(1, c);
|
||||
@(return c)
|
||||
}
|
||||
|
||||
static cl_object
|
||||
|
|
@ -1222,10 +1242,7 @@ stream_or_default_input(cl_object stream)
|
|||
return stream;
|
||||
}
|
||||
|
||||
@(defun read (&optional (strm Cnil)
|
||||
(eof_errorp Ct)
|
||||
eof_value
|
||||
recursivep)
|
||||
@(defun read (&optional (strm Cnil) (eof_errorp Ct) eof_value recursivep)
|
||||
cl_object x;
|
||||
@
|
||||
strm = stream_or_default_input(strm);
|
||||
|
|
@ -1289,8 +1306,9 @@ do_read_delimited_list(int d, cl_object strm)
|
|||
|
||||
@(defun read_delimited_list (d &optional (strm Cnil) recursivep)
|
||||
cl_object l;
|
||||
int delimiter = char_code(d);
|
||||
int delimiter;
|
||||
@
|
||||
delimiter = char_code(d);
|
||||
strm = stream_or_default_input(strm);
|
||||
if (Null(recursivep))
|
||||
l = do_read_delimited_list(delimiter, strm);
|
||||
|
|
@ -1545,8 +1563,6 @@ cl_readtablep(cl_object readtable)
|
|||
@(return ((type_of(readtable) == t_readtable)? Ct : Cnil))
|
||||
}
|
||||
|
||||
/* FIXME! READTABLE-CASE is missing! */
|
||||
|
||||
static struct ecl_readtable_entry*
|
||||
read_table_entry(cl_object rdtbl, cl_object c)
|
||||
{
|
||||
|
|
@ -1555,6 +1571,12 @@ read_table_entry(cl_object rdtbl, cl_object c)
|
|||
return &(rdtbl->readtable.table[char_code(c)]);
|
||||
}
|
||||
|
||||
bool
|
||||
ecl_invalid_character_p(int c)
|
||||
{
|
||||
return (c < 32) || (c == 127);
|
||||
}
|
||||
|
||||
@(defun set_syntax_from_char (tochr fromchr
|
||||
&o (tordtbl ecl_current_readtable())
|
||||
fromrdtbl)
|
||||
|
|
|
|||
|
|
@ -59,9 +59,9 @@ cl_symbols[] = {
|
|||
{"*ERROR-OUTPUT*", CL_SPECIAL, NULL, -1, OBJNULL},
|
||||
{"*FEATURES*", CL_SPECIAL, NULL, -1, OBJNULL},
|
||||
{"*GENSYM-COUNTER*", CL_SPECIAL, NULL, -1, MAKE_FIXNUM(0)},
|
||||
{"*LOAD-PATHNAME*", CL_SPECIAL, NULL, -1, OBJNULL},
|
||||
{"*LOAD-PATHNAME*", CL_SPECIAL, NULL, -1, Cnil},
|
||||
{"*LOAD-PRINT*", CL_SPECIAL, NULL, -1, Cnil},
|
||||
{"*LOAD-TRUENAME*", CL_SPECIAL, NULL, -1, OBJNULL},
|
||||
{"*LOAD-TRUENAME*", CL_SPECIAL, NULL, -1, Cnil},
|
||||
{"*LOAD-VERBOSE*", CL_SPECIAL, NULL, -1, Ct},
|
||||
{"*MACROEXPAND-HOOK*", CL_SPECIAL, NULL, -1, OBJNULL},
|
||||
{"*MODULES*", CL_SPECIAL, NULL, -1, OBJNULL},
|
||||
|
|
@ -976,14 +976,14 @@ cl_symbols[] = {
|
|||
{"GENERIC-FUNCTION", CL_ORDINARY, NULL, -1, OBJNULL},
|
||||
{"IF", CL_FORM, NULL, -1, OBJNULL},
|
||||
{"INITIALIZE-INSTANCE", CL_ORDINARY, NULL, -1, OBJNULL},
|
||||
{"INVALID-METHOD-ERROR", CL_ORDINARY, NULL, -1, OBJNULL},
|
||||
{"INVALID-METHOD-ERROR", CL_ORDINARY, _D(cl_invalid_method_error), -1, OBJNULL},
|
||||
{"MAKE-INSTANCE", CL_ORDINARY, NULL, -1, OBJNULL},
|
||||
{"MAKE-INSTANCES-OBSOLETE", CL_ORDINARY, NULL, -1, OBJNULL},
|
||||
{"MAKE-LOAD-FORM", CL_ORDINARY, NULL, -1, OBJNULL},
|
||||
{"MAKE-LOAD-FORM-SAVING-SLOTS", CL_ORDINARY, NULL, -1, OBJNULL},
|
||||
{"MAKE-METHOD", CL_ORDINARY, NULL, -1, OBJNULL},
|
||||
{"METHOD", CL_ORDINARY, NULL, -1, OBJNULL},
|
||||
{"METHOD-COMBINATION-ERROR", CL_ORDINARY, NULL, -1, OBJNULL},
|
||||
{"METHOD-COMBINATION-ERROR", CL_ORDINARY, _D(cl_method_combination_error), -1, OBJNULL},
|
||||
{"METHOD-COMBINATION", CL_ORDINARY, NULL, -1, OBJNULL},
|
||||
{"METHOD-QUALIFIERS", CL_ORDINARY, NULL, -1, OBJNULL},
|
||||
{"NEXT-METHOD-P", CL_ORDINARY, NULL, -1, OBJNULL},
|
||||
|
|
|
|||
|
|
@ -77,7 +77,7 @@ si_close_pipe(cl_object stream)
|
|||
#else
|
||||
if (type_of(stream) == t_stream &&
|
||||
stream->stream.object1 == @'si::open-pipe') {
|
||||
stream->stream.mode = smm_closed;
|
||||
stream->stream.closed = 1;
|
||||
pclose(stream->stream.file);
|
||||
stream->stream.file = NULL;
|
||||
stream->stream.object0 = OBJNULL;
|
||||
|
|
|
|||
|
|
@ -95,7 +95,8 @@
|
|||
(apply #'change-class instance (find-class new-class) initargs))
|
||||
|
||||
(defmethod make-instances-obsolete ((class symbol))
|
||||
(make-instances-obsolete (find-class class)))
|
||||
(make-instances-obsolete (find-class class))
|
||||
class)
|
||||
|
||||
(defmethod make-instance ((class-name symbol) &rest initargs)
|
||||
(apply #'make-instance (find-class class-name) initargs))
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@
|
|||
;;;
|
||||
;;; *effective-method-templates* is a list of effective-method template
|
||||
;;; entries. Each entry is itself a list of the form:
|
||||
;;;
|
||||
;;;
|
||||
;;; (<template> <match-function> <make-code-function> <when> <count>)
|
||||
;;;
|
||||
;;; The match function is simple-effective-method-match-p.
|
||||
|
|
@ -412,6 +412,16 @@
|
|||
(define-complex-method-combination (list* name body))
|
||||
(apply #'define-simple-method-combination name body)))
|
||||
|
||||
(defun method-combination-error (format-control &rest args)
|
||||
;; FIXME! We should emit a more detailed error!
|
||||
(error "Method-combination error:~%~S"
|
||||
(apply #'format nil format-control args)))
|
||||
|
||||
(defun invalid-method-error (method format-control &rest args)
|
||||
(error "Invalid method error for ~A~%~S"
|
||||
method
|
||||
(apply #'format nil format-control args)))
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; COMPUTE-EFFECTIVE-METHOD
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -95,7 +95,7 @@ and cannot be added to ~A." method other-gf gf)))
|
|||
(error "Cannot add the method ~A to the generic function ~A because ~
|
||||
their lambda lists ~A and ~A are not congruent."
|
||||
method gf old-lambda-list new-lambda-list)))
|
||||
(setf (generic-function-lambda-list gf) new-lambda-list)))
|
||||
(reinitialize-instance gf :lambda-list new-lambda-list)))
|
||||
;;
|
||||
;; 3) Finally, it is inserted in the list of methods, and the method is
|
||||
;; marked as belonging to a generic function.
|
||||
|
|
@ -120,8 +120,7 @@ their lambda lists ~A and ~A are not congruent."
|
|||
;; iii) Computing a new discriminating function... Well, since the core
|
||||
;; ECL does not need the discriminating function because we always use
|
||||
;; the same one, we just update the spec-how list of the generic function.
|
||||
(setf (generic-function-spec-list gf) (compute-g-f-spec-list gf))
|
||||
(clrhash (generic-function-method-hash gf))
|
||||
(compute-g-f-spec-list gf)
|
||||
gf))
|
||||
|
||||
(setf (method-function
|
||||
|
|
|
|||
|
|
@ -173,6 +173,12 @@
|
|||
(lambda-list-required-arguments lambda-list)))
|
||||
gfun)
|
||||
|
||||
(defmethod shared-initialize ((gfun standard-generic-function) slot-names
|
||||
&rest initargs)
|
||||
(call-next-method)
|
||||
(compute-g-f-spec-list gfun)
|
||||
gfun)
|
||||
|
||||
(defmethod ensure-generic-function-using-class
|
||||
((gfun generic-function) name &rest args &key (method-class 'STANDARD-METHOD)
|
||||
(generic-function-class (class-of gfun))
|
||||
|
|
@ -183,19 +189,23 @@
|
|||
(remf args :declare)
|
||||
(remf args :environment)
|
||||
(remf args :delete-methods)
|
||||
;; FIXME! We should check that the class GENERIC-FUNCTION-CLASS is compatible
|
||||
;; with the old one. In what sense "compatible" is ment, I do not know!
|
||||
;; (See ANSI DEFGENERIC entry)
|
||||
(when (symbolp generic-function-class)
|
||||
(setf generic-function-class (find-class generic-function-class)))
|
||||
(unless (eq (class-of gfun) generic-function-class)
|
||||
(simple-program-error "Tried to change the class of the generic function ~A"
|
||||
gfun))
|
||||
(unless (si::subclassp generic-function-class (find-class 'generic-function))
|
||||
(error "~A is not a valid :GENERIC-FUNCTION-CLASS argument for ENSURE-GENERIC-FUNCTION."
|
||||
generic-function-class))
|
||||
(when delete-methods
|
||||
(dolist (m (copy-list (generic-function-methods gfun)))
|
||||
(when (method-from-defgeneric-p m)
|
||||
(remove-method gfun m))))
|
||||
(unless (classp method-class)
|
||||
(setf args (list* :method-class (find-class method-class) args)))
|
||||
;; FIXME! WE MUST IMPLEMENT REINITIALIZATION OF GENERIC FUNCTIONS
|
||||
(apply #'reinitialize-instance gfun :name name args))
|
||||
(if (eq (class-of gfun) generic-function-class)
|
||||
(apply #'reinitialize-instance gfun :name name args)
|
||||
(apply #'change-class gfun generic-function-class :name name args)))
|
||||
|
||||
(defmethod ensure-generic-function-using-class
|
||||
((gfun null) name &rest args &key (method-class 'STANDARD-METHOD)
|
||||
|
|
@ -214,12 +224,15 @@
|
|||
t))
|
||||
|
||||
(defun ensure-generic-function (name &rest args &key &allow-other-keys)
|
||||
(let ((gfun nil))
|
||||
(let ((gfun nil)
|
||||
(traced nil))
|
||||
(when (setf traced (get-sysprop name 'SI::TRACED))
|
||||
(setf gfun (fdefinition traced)))
|
||||
(cond ((not (legal-generic-function-name-p name))
|
||||
(simple-program-error "~A is not a valid generic function name" name))
|
||||
((not (fboundp name)))
|
||||
;; a generic function already exists
|
||||
((si::instancep (setf gfun (fdefinition name))))
|
||||
((si::instancep (or gfun (setf gfun (fdefinition name)))))
|
||||
((special-operator-p name)
|
||||
(simple-program-error "The special operator ~A is not a valid name for a generic function" name))
|
||||
((macro-function name)
|
||||
|
|
@ -227,5 +240,5 @@
|
|||
(t
|
||||
(simple-program-error "The symbol ~A is bound to an ordinary function and is not a valid name for a generic function" name))
|
||||
)
|
||||
(setf (fdefinition name)
|
||||
(setf (fdefinition (or traced name))
|
||||
(apply #'ensure-generic-function-using-class gfun name args))))
|
||||
|
|
|
|||
|
|
@ -96,14 +96,15 @@
|
|||
:accessor generic-function-lambda-list)
|
||||
(argument-precedence-order
|
||||
:initarg :argument-precedence-order
|
||||
:initform :default
|
||||
:initform nil
|
||||
:accessor generic-function-argument-precedence-order)
|
||||
(method-class
|
||||
:initarg :method-class
|
||||
:initform (find-class 'standard-method)
|
||||
:accessor generic-function-method-class)
|
||||
(documentation :initarg :documentation)
|
||||
(methods :initform nil :accessor generic-function-methods))))
|
||||
(methods :initform nil :accessor generic-function-methods)
|
||||
(a-p-o-function :initform nil :accessor generic-function-a-p-o-function))))
|
||||
|
||||
#.(create-accessors +standard-generic-function-slots+
|
||||
'standard-generic-function)
|
||||
|
|
@ -149,7 +150,6 @@
|
|||
((si::instancep x) x)
|
||||
(t (find-class x))))
|
||||
specializers))
|
||||
(spec-how-list (generic-function-spec-list gf))
|
||||
(method (make-method qualifiers specializers lambda-list
|
||||
fun plist options gf
|
||||
(generic-function-method-class gf))))
|
||||
|
|
@ -160,7 +160,7 @@
|
|||
;;; early versions
|
||||
|
||||
;;; early version used during bootstrap
|
||||
(defun ensure-generic-function (name &key (lambda-list (si::unbound)))
|
||||
(defun ensure-generic-function (name &key (lambda-list (si::unbound) l-l-p))
|
||||
(if (and (fboundp name) (si::instancep (fdefinition name)))
|
||||
(fdefinition name)
|
||||
;; create a fake standard-generic-function object:
|
||||
|
|
@ -177,11 +177,13 @@
|
|||
(si::instance-sig-set gfun)
|
||||
(setf (generic-function-name gfun) name
|
||||
(generic-function-lambda-list gfun) lambda-list
|
||||
(generic-function-argument-precedence-order gfun) 'default
|
||||
(generic-function-method-combination gfun) '(standard)
|
||||
(generic-function-methods gfun) nil
|
||||
(generic-function-spec-list gfun) nil
|
||||
(generic-function-method-hash gfun) hash)
|
||||
(when l-l-p
|
||||
(setf (generic-function-argument-precedence-order gfun)
|
||||
(rest (si::process-lambda-list lambda-list t))))
|
||||
(si::set-funcallable gfun t)
|
||||
(setf (fdefinition name) gfun)
|
||||
gfun)))
|
||||
|
|
@ -203,7 +205,7 @@
|
|||
(cdr scan-specializers))
|
||||
(arg)
|
||||
(spec))
|
||||
;; check if the method is applicable verifying
|
||||
;; check if the method is applicable verifying
|
||||
;; if each argument satisfies the corresponding
|
||||
;; parameter specializers
|
||||
((null scan-args) (push method applicable-list))
|
||||
|
|
@ -219,6 +221,7 @@
|
|||
;; then order the list
|
||||
(do* ((scan applicable-list)
|
||||
(most-specific (first scan) (first scan))
|
||||
(f (generic-function-a-p-o-function gf))
|
||||
(ordered-list))
|
||||
((null (cdr scan)) (when most-specific
|
||||
;; at least one method
|
||||
|
|
@ -228,7 +231,7 @@
|
|||
(push most-specific ordered-list))))
|
||||
(dolist (meth (cdr scan))
|
||||
(when (eq (compare-methods most-specific
|
||||
meth args-specializers) 2)
|
||||
meth args-specializers f) 2)
|
||||
(setq most-specific meth)))
|
||||
(setq scan (delete most-specific scan))
|
||||
(push most-specific ordered-list))))
|
||||
|
|
@ -236,12 +239,13 @@
|
|||
;;; ----------------------------------------------------------------------
|
||||
;;; method comparison
|
||||
|
||||
(defun compare-methods (method-1 method-2 args-specializers)
|
||||
(defun compare-methods (method-1 method-2 args-specializers f)
|
||||
(declare (si::c-local))
|
||||
(let* ((specializers-list-1 (method-specializers method-1))
|
||||
(specializers-list-2 (method-specializers method-2)))
|
||||
(compare-specializers-lists specializers-list-1
|
||||
specializers-list-2 args-specializers)))
|
||||
(compare-specializers-lists (if f (funcall f specializers-list-1) specializers-list-1)
|
||||
(if f (funcall f specializers-list-2) specializers-list-2)
|
||||
args-specializers)))
|
||||
|
||||
(defun compare-specializers-lists (spec-list-1 spec-list-2 args-specializers)
|
||||
(declare (si::c-local))
|
||||
|
|
@ -279,38 +283,53 @@
|
|||
)))
|
||||
|
||||
(defun compute-g-f-spec-list (gf)
|
||||
(do* ((spec-how-list nil)
|
||||
(methods (generic-function-methods gf) (rest methods))
|
||||
method
|
||||
specializers)
|
||||
((null methods)
|
||||
spec-how-list)
|
||||
(setf method (first methods)
|
||||
specializers (method-specializers method))
|
||||
;; FIXME! This check should have happened before, shouldn't it???
|
||||
(let ((l (length specializers)))
|
||||
(if spec-how-list
|
||||
(unless (= (length spec-how-list) l)
|
||||
(error "The generic function ~A~%has ~D required arguments, but the new specialization provides ~D."
|
||||
gf (length spec-how-list) l))
|
||||
(setf spec-how-list (make-list l))))
|
||||
;; update the spec-how of the gfun
|
||||
;; computing the or of the previous value and the new one
|
||||
(do* ((l specializers (cdr l))
|
||||
(l2 spec-how-list (cdr l2))
|
||||
(spec-how)
|
||||
(spec-how-old))
|
||||
((null l))
|
||||
(setq spec-how (first l) spec-how-old (first l2))
|
||||
(setf (first l2)
|
||||
(if (consp spec-how) ; an eql list
|
||||
(if (consp spec-how-old)
|
||||
(list* (second spec-how) spec-how-old)
|
||||
(cdr spec-how))
|
||||
(if (consp spec-how-old)
|
||||
spec-how-old
|
||||
(or spec-how spec-how-old)))))
|
||||
))
|
||||
(flet ((nupdate-spec-how-list (spec-how-list specializers gf)
|
||||
;; FIXME! This check should have happened before, shouldn't it???
|
||||
(let ((l (length specializers)))
|
||||
(if spec-how-list
|
||||
(unless (= (length spec-how-list) l)
|
||||
(error "The generic function ~A~%has ~D required arguments, but the new specialization provides ~D."
|
||||
gf (length spec-how-list) l))
|
||||
(setf spec-how-list (make-list l))))
|
||||
;; update the spec-how of the gfun
|
||||
;; computing the or of the previous value and the new one
|
||||
(do* ((l specializers (cdr l))
|
||||
(l2 spec-how-list (cdr l2))
|
||||
(spec-how)
|
||||
(spec-how-old))
|
||||
((null l))
|
||||
(setq spec-how (first l) spec-how-old (first l2))
|
||||
(setf (first l2)
|
||||
(if (consp spec-how) ; an eql list
|
||||
(if (consp spec-how-old)
|
||||
(list* (second spec-how) spec-how-old)
|
||||
(cdr spec-how))
|
||||
(if (consp spec-how-old)
|
||||
spec-how-old
|
||||
(or spec-how spec-how-old)))))
|
||||
spec-how-list))
|
||||
(let* ((spec-how-list nil)
|
||||
(function nil)
|
||||
(a-p-o (generic-function-argument-precedence-order gf)))
|
||||
(dolist (method (generic-function-methods gf))
|
||||
(setf spec-how-list
|
||||
(nupdate-spec-how-list spec-how-list (method-specializers method) gf)))
|
||||
(setf (generic-function-spec-list gf)
|
||||
(loop for type in spec-how-list
|
||||
for name in (generic-function-lambda-list gf)
|
||||
for i from 0
|
||||
when type collect (cons type (position name a-p-o))))
|
||||
(let* ((g-f-l-l (generic-function-lambda-list gf)))
|
||||
(when (consp g-f-l-l)
|
||||
(let ((required-arguments (rest (si::process-lambda-list g-f-l-l t))))
|
||||
(unless (equal a-p-o required-arguments)
|
||||
(setf function
|
||||
(coerce `(lambda (%list)
|
||||
(destructuring-bind ,required-arguments %list
|
||||
(list ,@a-p-o)))
|
||||
'function))))))
|
||||
(setf (generic-function-a-p-o-function gf) function)
|
||||
(clrhash (generic-function-method-hash gf)))))
|
||||
|
||||
(defun print-object (object stream)
|
||||
(print-unreadable-object (object stream)))
|
||||
|
|
@ -560,8 +560,10 @@
|
|||
(push method (generic-function-methods gf))
|
||||
(setf (method-generic-function method) gf)
|
||||
(unless (si::sl-boundp (generic-function-lambda-list gf))
|
||||
(setf (generic-function-lambda-list gf) (method-lambda-list method)))
|
||||
(setf (generic-function-spec-list gf) (compute-g-f-spec-list gf))
|
||||
(setf (generic-function-lambda-list gf) (method-lambda-list method))
|
||||
(setf (generic-function-argument-precedence-order gf)
|
||||
(rest (si::process-lambda-list (method-lambda-list method) t))))
|
||||
(compute-g-f-spec-list gf)
|
||||
method))
|
||||
|
||||
(defun find-method (gf qualifiers specializers &optional (errorp t))
|
||||
|
|
@ -578,7 +580,7 @@
|
|||
;; specializers might have the wrong size and we must signal
|
||||
;; an error.
|
||||
(cond ((/= (length specializers)
|
||||
(length (generic-function-spec-list gf)))
|
||||
(length (generic-function-argument-precedence-order gf)))
|
||||
(error
|
||||
"The specializers list~%~A~%does not match the number of required arguments in ~A"
|
||||
specializers (generic-function-name gf)))
|
||||
|
|
|
|||
|
|
@ -100,8 +100,6 @@
|
|||
(check-initargs class initargs
|
||||
(append (compute-applicable-methods
|
||||
#'allocate-instance (list class))
|
||||
(compute-applicable-methods
|
||||
#'make-instance (list (class-prototype class)))
|
||||
(compute-applicable-methods
|
||||
#'initialize-instance (list (class-prototype class)))
|
||||
(compute-applicable-methods
|
||||
|
|
|
|||
|
|
@ -364,6 +364,7 @@
|
|||
(name &optional (template '(NIL REPEAT (EVAL))))
|
||||
`(eval-when (load eval)
|
||||
(put-sysprop ',name 'WALKER-TEMPLATE ',template)))
|
||||
)
|
||||
|
||||
(defun get-walker-template (x)
|
||||
(cond ((symbolp x)
|
||||
|
|
|
|||
|
|
@ -188,7 +188,7 @@
|
|||
x))
|
||||
|
||||
(defun add-object (object &optional (duplicate nil))
|
||||
(when (typep object '(or function package))
|
||||
(when (and (not *compiler-constants*) (typep object '(or function package)))
|
||||
(error "Object ~S cannot be externalized" object))
|
||||
(let* ((test (if *compiler-constants* 'eq 'equal))
|
||||
(x (assoc object *objects* :test test))
|
||||
|
|
|
|||
|
|
@ -891,15 +891,15 @@ type_of(#0)==t_bitvector"))
|
|||
|
||||
; file character.d
|
||||
(CHAR (string fixnum) character nil nil
|
||||
:inline-always ((t t) t nil t "elt(#0,fixint(#1))")
|
||||
:inline-always ((t fixnum) t nil t "elt(#0,#1)")
|
||||
:inline-always ((t t) t nil t "cl_char(#0,#1)")
|
||||
:inline-always ((t fixnum) t nil t "aref1(#0,#1)")
|
||||
:inline-unsafe ((t t) t nil nil "CODE_CHAR((#0)->string.self[fix(#1)])")
|
||||
:inline-unsafe ((t fixnum) fixnum nil nil "(#0)->string.self[#1]")
|
||||
:inline-unsafe ((t fixnum) character nil nil "(#0)->string.self[#1]"))
|
||||
(si::CHAR-SET
|
||||
(string fixnum character) character nil nil
|
||||
:inline-always ((t t t) t t nil "elt_set(#0,fixint(#1),#2)")
|
||||
:inline-always ((t fixnum t) t t nil "elt_set(#0,#1,#2)")
|
||||
:inline-always ((t t t) t t nil "si_char_set(#0,#1,#2)")
|
||||
:inline-always ((t fixnum t) t t nil "aset1(#0,#1,#2)")
|
||||
:inline-unsafe ((t t t) t t nil
|
||||
"@2;((#0)->string.self[fix(#1)]=char_code(#2),(#2))")
|
||||
:inline-unsafe ((t fixnum character) character t nil
|
||||
|
|
@ -1111,10 +1111,16 @@ type_of(#0)==t_bitvector"))
|
|||
;; pprint.lsp
|
||||
pprint-fill copy-pprint-dispatch pprint-dispatch
|
||||
pprint-linear pprint-newline pprint-tab pprint-tabular
|
||||
set-pprint-dispatch pprint-indent
|
||||
set-pprint-dispatch pprint-indent .
|
||||
#-clos
|
||||
nil
|
||||
#+clos
|
||||
(;; combin.lsp
|
||||
method-combination-error
|
||||
invalid-method-error)
|
||||
))
|
||||
|
||||
(proclaim
|
||||
(proclaim
|
||||
`(si::c-export-fname #+ecl-min ,@c::*in-all-symbols-functions*
|
||||
si::ecase-error si::etypecase-error
|
||||
ccase-error typecase-error-string find-documentation find-declarations
|
||||
|
|
|
|||
|
|
@ -1149,6 +1149,7 @@ extern cl_object read_object_non_recursive(cl_object in);
|
|||
extern cl_object read_object(cl_object in);
|
||||
extern cl_object parse_number(const char *s, cl_index end, cl_index *ep, int radix);
|
||||
extern cl_object parse_integer(const char *s, cl_index end, cl_index *ep, int radix);
|
||||
extern bool ecl_invalid_character_p(int c);
|
||||
extern cl_object copy_readtable(cl_object from, cl_object to);
|
||||
extern cl_object ecl_current_readtable(void);
|
||||
extern int ecl_current_read_base(void);
|
||||
|
|
@ -1644,6 +1645,10 @@ extern cl_object cl_set_pprint_dispatch _ARGS((cl_narg narg, cl_object V1, cl_ob
|
|||
/* defclass.lsp */
|
||||
extern cl_object clos_ensure_class _ARGS((cl_narg narg, cl_object V1, ...));
|
||||
|
||||
/* combin.lsp */
|
||||
extern cl_object cl_method_combination_error _ARGS((cl_narg narg, cl_object format, ...));
|
||||
extern cl_object cl_invalid_method_error _ARGS((cl_narg narg, cl_object method, cl_object format, ...));
|
||||
|
||||
/* kernel.lsp */
|
||||
extern cl_object clos_class_id _ARGS((cl_narg narg, cl_object V1, ...));
|
||||
extern cl_object clos_class_direct_superclasses _ARGS((cl_narg narg, cl_object V1, ...));
|
||||
|
|
|
|||
|
|
@ -284,7 +284,6 @@ struct ecl_structure { /* structure header */
|
|||
#endif
|
||||
|
||||
enum ecl_smmode { /* stream mode */
|
||||
smm_closed, /* closed */
|
||||
smm_input, /* input */
|
||||
smm_output, /* output */
|
||||
smm_io, /* input-output */
|
||||
|
|
@ -304,7 +303,7 @@ enum ecl_smmode { /* stream mode */
|
|||
};
|
||||
|
||||
struct ecl_stream {
|
||||
HEADER3(mode,char_stream_p,signed_bytes);
|
||||
HEADER4(mode,closed,char_stream_p,signed_bytes);
|
||||
/* stream mode of enum smmode */
|
||||
/* stream element type */
|
||||
FILE *file; /* file pointer */
|
||||
|
|
|
|||
|
|
@ -1142,16 +1142,10 @@ collected result will be returned as the value of the LOOP."
|
|||
(declare (si::c-local))
|
||||
`(return-from ,(car *loop-names*) ,form))
|
||||
|
||||
|
||||
(defun loop-pseudo-body (form)
|
||||
(declare (si::c-local))
|
||||
(cond ((or *loop-emitted-body* *loop-inside-conditional*) (push form *loop-body*))
|
||||
(t (push form *loop-before-loop*) (push form *loop-after-body*))))
|
||||
|
||||
(defun loop-emit-body (form)
|
||||
(declare (si::c-local))
|
||||
(setq *loop-emitted-body* t)
|
||||
(loop-pseudo-body form))
|
||||
(push form *loop-body*))
|
||||
|
||||
(defun loop-emit-final-value (&optional (form nil form-supplied-p))
|
||||
(declare (si::c-local))
|
||||
|
|
@ -1379,7 +1373,7 @@ collected result will be returned as the value of the LOOP."
|
|||
(when (loop-tequal (car *loop-source-code*) :end)
|
||||
(loop-pop-source))
|
||||
(when it-p (setq form `(setq ,it-p ,form)))
|
||||
(loop-pseudo-body
|
||||
(loop-emit-body
|
||||
`(if ,(if negatep `(not ,form) form)
|
||||
,then
|
||||
,@else))))))
|
||||
|
|
@ -1408,7 +1402,7 @@ collected result will be returned as the value of the LOOP."
|
|||
(setq *loop-names* (list name nil))))
|
||||
|
||||
(defun loop-do-return ()
|
||||
(loop-pseudo-body (loop-construct-return (loop-get-form))))
|
||||
(loop-emit-body (loop-construct-return (loop-get-form))))
|
||||
|
||||
|
||||
;;;; Value Accumulation: List
|
||||
|
|
@ -1556,7 +1550,7 @@ collected result will be returned as the value of the LOOP."
|
|||
|
||||
(defun loop-do-while (negate kwd &aux (form (loop-get-form)))
|
||||
(loop-disallow-conditional kwd)
|
||||
(loop-pseudo-body `(,(if negate 'when 'unless) ,form (go end-loop))))
|
||||
(loop-emit-body `(,(if negate 'when 'unless) ,form (go end-loop))))
|
||||
|
||||
|
||||
(defun loop-do-with ()
|
||||
|
|
@ -2052,6 +2046,8 @@ collected result will be returned as the value of the LOOP."
|
|||
|
||||
|
||||
(defun loop-for-arithmetic (var val data-type kwd)
|
||||
(unless var
|
||||
(setf var (loop-gentemp)))
|
||||
(loop-sequencer
|
||||
var (loop-check-data-type data-type *loop-real-data-type*) t
|
||||
nil nil nil nil nil nil
|
||||
|
|
|
|||
|
|
@ -28,11 +28,17 @@ The doc-string DOC, if supplied, is saved as a TYPE doc and can be retrieved
|
|||
by (documentation 'NAME 'type)."
|
||||
(multiple-value-bind (body doc)
|
||||
(remove-documentation body)
|
||||
`(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(put-sysprop ',name 'DEFTYPE-FORM '(DEFTYPE ,name ,lambda-list ,@body))
|
||||
(put-sysprop ',name 'DEFTYPE-DEFINITION #'(LAMBDA ,lambda-list ,@body))
|
||||
,@(si::expand-set-documentation name 'type doc)
|
||||
',name)))
|
||||
(setf lambda-list (copy-list lambda-list))
|
||||
(do ((l (rest (member '&optional lambda-list)) (rest l)))
|
||||
((null l))
|
||||
(let ((variable (first l)))
|
||||
(when (symbolp variable)
|
||||
(setf (first l) `(,variable '*)))))
|
||||
`(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(put-sysprop ',name 'DEFTYPE-FORM '(DEFTYPE ,name ,lambda-list ,@body))
|
||||
(put-sysprop ',name 'DEFTYPE-DEFINITION #'(LAMBDA ,lambda-list ,@body))
|
||||
,@(si::expand-set-documentation name 'type doc)
|
||||
',name)))
|
||||
|
||||
|
||||
;;; Some DEFTYPE definitions.
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue