From 6d1ec50d38cc161b9b649b8a5b3fe7fdb89e43ea Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Fri, 12 Dec 2003 08:26:29 +0000 Subject: [PATCH] Fixed GCD. Implemented several stream functions. Fixed LCM. Fixed the inline expansions for ZEROP, PLUSP, MINUSP, ODDP and EVENP. Fixed the meaning and allowed values of REHASH-THRESHOLD. SXHASH now produces hash keys which are equal for EQUAL bitvectors. Implemented ARITHMETIC-ERROR-OPERANDS. Fixed a bug in hash table which duplicated the number of entries whenever the hash grew. --- src/CHANGELOG | 19 +++++ src/c/compiler.d | 2 + src/c/file.d | 179 +++++++++++++++++++++++++++++++--------- src/c/gfun.d | 16 +--- src/c/hash.d | 73 ++++++++-------- src/c/num_arith.d | 8 +- src/c/num_sfun.d | 2 +- src/c/package.d | 1 + src/c/symbols_list.h | 39 ++++----- src/c/typespec.d | 7 -- src/clos/conditions.lsp | 17 ++-- src/clos/kernel.lsp | 4 +- src/cmp/sysfun.lsp | 8 +- src/h/external.h | 11 ++- src/h/object.h | 5 +- src/lsp/numlib.lsp | 2 +- 16 files changed, 259 insertions(+), 134 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index be9651757..550ccbe7a 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -1734,6 +1734,10 @@ ECL 0.9d - SLOT-EXISTS-P now works with all types of objects. + - LCM now works when any of the arguments is 0. + + - SIGNUM now accepts complex arguments. + * Documentation: - New manual page documents the scripting facilities of ECL @@ -1771,6 +1775,21 @@ ECL 0.9d the standard. ECL extensions, such as the types BYTE8, UNSIGNED-BYTE8, are now in the package EXT (which is temporarily an alias of SYSTEM). + - The following functions have been implemented: BROADCAST-STREAM-STREAMS, + {ECHO,TWO-WAY}-STREAM-{INPUT,OUTPUT}-STREAM, FILE-STRING-LENGTH, + INTERACTIVE-STREAM-P (dummy), STREAM-EXTERNAL-FORMAT. + + - The generic function for handling CLOS streams (STREAM-READ-CHAR, + STREAM-CLEAR-INPUT, etc), are now in the EXT package. + + - HASH-TABLE-REHASH-THRESHOLD can now be any number in (REAL 0 1). Integers + above 1 are not allowed, and the threshold is always interpreted as the + relative filling of the hash table before growth (Before, the threshold + could be an integer number with a somewhat obscure interpretation). + + - SXHASH now always returns positive fixnums and produces the same key for + two bitvectors which are EQUAL. + TODO: ===== diff --git a/src/c/compiler.d b/src/c/compiler.d index a4ce2f816..5c3e5925d 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -1405,6 +1405,8 @@ c_macrolet(cl_object args, int flags) function = make_lambda(name, CDR(macro)); c_register_macro(name, function); } + /* Remove declarations */ + args = c_process_declarations(args); flags = compile_body(args, flags); ENV->macros = old_macros; diff --git a/src/c/file.d b/src/c/file.d index 416172cfb..3ee886026 100644 --- a/src/c/file.d +++ b/src/c/file.d @@ -53,7 +53,7 @@ input_stream_p(cl_object strm) BEGIN: #ifdef ECL_CLOS_STREAMS if (type_of(strm) == t_instance) - return !Null(funcall(2, @'stream-input-p')); + return !Null(funcall(2, @'ext::stream-input-p', strm)); #endif if (type_of(strm) != t_stream) FEtype_error_stream(strm); @@ -99,7 +99,7 @@ output_stream_p(cl_object strm) BEGIN: #ifdef ECL_CLOS_STREAMS if (type_of(strm) == t_instance) - return !Null(funcall(2, @'stream-output-p')); + return !Null(funcall(2, @'ext::stream-output-p', strm)); #endif if (type_of(strm) != t_stream) FEtype_error_stream(strm); @@ -192,6 +192,23 @@ BEGIN: @(return @'ext::byte8') } +cl_object +cl_stream_external_format(cl_object strm) +{ + cl_object output; + cl_type t = type_of(strm); +#ifdef ECL_CLOS_STREAMS + if (t == t_instance) + output = @':default'; + else +#endif + if (t == t_stream) + output = @':default'; + else + FEwrong_type_argument(@'stream', strm); + @(return output) +} + /*---------------------------------------------------------------------- * Error messages *---------------------------------------------------------------------- @@ -347,7 +364,7 @@ close_stream(cl_object strm, bool abort_flag) /* Not used now! */ #ifdef ECL_CLOS_STREAMS if (type_of(strm) == t_instance) { - funcall(2, @'stream-close', strm); + funcall(2, @'ext::stream-close', strm); return; } #endif @@ -415,16 +432,6 @@ make_two_way_stream(cl_object istrm, cl_object ostrm) return(strm); } -cl_object -make_echo_stream(cl_object istrm, cl_object ostrm) -{ - cl_object strm; - - strm = make_two_way_stream(istrm, ostrm); - strm->stream.mode = (short)smm_echo; - return(strm); -} - cl_object make_string_input_stream(cl_object strng, cl_index istart, cl_index iend) { @@ -516,7 +523,7 @@ ecl_getc(cl_object strm) BEGIN: #ifdef ECL_CLOS_STREAMS if (type_of(strm) == t_instance) { - cl_object c = funcall(2, @'stream-read-char', strm); + cl_object c = funcall(2, @'ext::stream-read-char', strm); return CHARACTERP(c)? CHAR_CODE(c) : EOF; } #endif @@ -605,7 +612,7 @@ ecl_ungetc(int c, cl_object strm) BEGIN: #ifdef ECL_CLOS_STREAMS if (type_of(strm) == t_instance) { - funcall(3, @'stream-unread-char', strm, CODE_CHAR(c)); + funcall(3, @'ext::stream-unread-char', strm, CODE_CHAR(c)); return; } #endif @@ -676,7 +683,7 @@ writec_stream(int c, cl_object strm) BEGIN: #ifdef ECL_CLOS_STREAMS if (type_of(strm) == t_instance) { - funcall(3, @'stream-write-char', strm, CODE_CHAR(c)); + funcall(3, @'ext::stream-write-char', strm, CODE_CHAR(c)); return c; } #endif @@ -873,7 +880,7 @@ flush_stream(cl_object strm) BEGIN: #ifdef ECL_CLOS_STREAMS if (type_of(strm) == t_instance) { - funcall(2, @'stream-force-output', strm); + funcall(2, @'ext::stream-force-output', strm); return; } #endif @@ -932,7 +939,7 @@ clear_input_stream(cl_object strm) BEGIN: #ifdef ECL_CLOS_STREAMS if (type_of(strm) == t_instance) { - funcall(2, @'stream-clear-input', strm); + funcall(2, @'ext::stream-clear-input', strm); return; } #endif @@ -992,7 +999,7 @@ clear_output_stream(cl_object strm) BEGIN: #ifdef ECL_CLOS_STREAMS if (type_of(strm) == t_instance) { - funcall(2, @'stream-clear-output',strm); + funcall(2, @'ext::stream-clear-output',strm); return; } #endif @@ -1156,7 +1163,7 @@ listen_stream(cl_object strm) BEGIN: #ifdef ECL_CLOS_STREAMS if (type_of(strm) == t_instance) { - cl_object flag = funcall(2, @'stream-listen', strm); + cl_object flag = funcall(2, @'ext::stream-listen', strm); return !(strm == Cnil); } #endif @@ -1413,7 +1420,14 @@ cl_make_synonym_stream(cl_object sym) @(return x) } - +cl_object +cl_synonym_stream_symbol(cl_object strm) +{ + if (type_of(strm) != t_stream || strm->stream.mode != smm_synonym) + FEwrong_type_argument(@'synonym-stream', strm); + @(return strm->stream.object0) +} + @(defun make_broadcast_stream (&rest ap) cl_object x, streams; int i; @@ -1421,7 +1435,7 @@ cl_make_synonym_stream(cl_object sym) streams = Cnil; for (i = 0; i < narg; i++) { x = cl_va_arg(ap); - if (type_of(x) != t_stream || !output_stream_p(x)) + if (!output_stream_p(x)) not_an_output_stream(x); streams = CONS(x, streams); } @@ -1434,6 +1448,14 @@ cl_make_synonym_stream(cl_object sym) @(return x) @) +cl_object +cl_broadcast_stream_streams(cl_object strm) +{ + if (type_of(strm) != t_stream || strm->stream.mode != smm_broadcast) + FEwrong_type_argument(@'broadcast-stream', strm); + return cl_copy_list(strm->stream.object0); +} + @(defun make_concatenated_stream (&rest ap) cl_object x, streams; int i; @@ -1441,7 +1463,7 @@ cl_make_synonym_stream(cl_object sym) streams = Cnil; for (i = 0; i < narg; i++) { x = cl_va_arg(ap); - if (type_of(x) != t_stream || !input_stream_p(x)) + if (!input_stream_p(x)) not_an_input_stream(x); streams = CONS(x, streams); } @@ -1454,35 +1476,67 @@ cl_make_synonym_stream(cl_object sym) @(return x) @) -/* FIXME! BROADCAST-STREAM-STREAMS is missing! */ -/* FIXME! CONCATENATED-STREAM-STREAMS is missing! */ -/* FIXME! ECHO-STREAM-INPUT-STREAM is missing! */ -/* FIXME! ECHO-STREAM-OUTPUT-STREAM is missing! */ -/* FIXME! TWO-WAY-STREAM-INPUT-STREAM is missing! */ -/* FIXME! TWO-WAY-STREAM-OUTPUT-STREAM is missing! */ -/* FIXME! FILE-STRING-LENGTH is missing! */ -/* FIXME! INTERACTIVE-STREAM-P is missing! */ -/* FIXME! STREAM-EXTERNAL-FORMAT is missing! */ -/* FIXME! SYNONYM-STREAM-SYMBOL is missing! */ +cl_object +cl_concatenated_stream_streams(cl_object strm) +{ + if (type_of(strm) != t_stream || strm->stream.mode != smm_concatenated) + FEwrong_type_argument(@'concatenated-stream', strm); + return cl_copy_list(strm->stream.object0); +} cl_object cl_make_two_way_stream(cl_object strm1, cl_object strm2) { - if (type_of(strm1) != t_stream || !input_stream_p(strm1)) + if (!input_stream_p(strm1)) not_an_input_stream(strm1); - if (type_of(strm2) != t_stream || !output_stream_p(strm2)) + if (!output_stream_p(strm2)) not_an_output_stream(strm2); @(return make_two_way_stream(strm1, strm2)) } +cl_object +cl_two_way_stream_input_stream(cl_object strm) +{ + if (type_of(strm) != t_stream || strm->stream.mode != smm_two_way) + FEwrong_type_argument(@'two-way-stream', strm); + @(return strm->stream.object0) +} + +cl_object +cl_two_way_stream_output_stream(cl_object strm) +{ + if (type_of(strm) != t_stream || strm->stream.mode != smm_two_way) + FEwrong_type_argument(@'two-way-stream', strm); + @(return strm->stream.object1) +} + cl_object cl_make_echo_stream(cl_object strm1, cl_object strm2) { - if (type_of(strm1) != t_stream || !input_stream_p(strm1)) + cl_object output; + if (!input_stream_p(strm1)) not_an_input_stream(strm1); - if (type_of(strm2) != t_stream || !output_stream_p(strm2)) + if (!output_stream_p(strm2)) not_an_output_stream(strm2); - @(return make_echo_stream(strm1, strm2)) + output = make_two_way_stream(strm1, strm2); + output->stream.mode = smm_echo; + @(return output) +} + +cl_object +cl_echo_stream_input_stream(cl_object strm) +{ + if (type_of(strm) != t_stream || strm->stream.mode != smm_echo) + FEwrong_type_argument(@'echo-stream', strm); + @(return strm->stream.object0) +} + +cl_object +cl_echo_stream_output_stream(cl_object strm) +{ + if (type_of(strm) != t_stream || strm->stream.mode != smm_echo) + FEwrong_type_argument(@'echo-stream', strm); + @(return strm->stream.object1) } @(defun make_string_input_stream (strng &o istart iend) @@ -1637,9 +1691,27 @@ for the file-stream ~S.", if (file_position_set(file_stream, i) < 0) @(return Cnil) @(return Ct) - } + } @) +cl_object +cl_file_string_length(cl_object string) +{ + cl_fixnum l; + switch (type_of(string)) { + case t_string: + l = string->string.fillp; + break; + case t_character: + l = 1; + break; + default: + FEwrong_type_argument(@'string', string); + } + @(return MAKE_FIXNUM(l)) +} + + cl_object cl_file_length(cl_object strm) { @@ -1681,6 +1753,35 @@ si_copy_stream(cl_object in, cl_object out) @(return Ct) } +cl_object +cl_interactive_stream_p(cl_object strm) +{ + cl_object output = Cnil; + cl_type t; + BEGIN: + t = type_of(strm); +#ifdef ECL_CLOS_STREAMS + if (t == t_instance) + return funcall(2, @'ext::stream-interactive-p', strm); +#endif + if (t != t_stream) + FEtype_error_stream(strm); + switch(strm->stream.mode) { + case smm_synonym: + strm = symbol_value(strm->stream.object0); + goto BEGIN; + case smm_input: +#ifdef HAVE_ISATTY + /* Here we should check for the type of file descriptor, + * and whether it is connected to a tty. */ + output = Cnil; +#endif + break; + default: + } + @(return output) +} + void init_file(void) { diff --git a/src/c/gfun.d b/src/c/gfun.d index 9ef3e5216..dcf075763 100644 --- a/src/c/gfun.d +++ b/src/c/gfun.d @@ -73,25 +73,15 @@ set_meth_hash(cl_object *keys, int argno, cl_object hashtable, cl_object value) struct ecl_hashtable_entry *e; cl_object keylist, *p; cl_index i; - bool over; i = hashtable->hash.entries + 1; if (i > 512) { /* It does not make sense to let these hashes grow large */ cl_clrhash(hashtable); - over = FALSE; - } else if (i >= hashtable->hash.size) - over = TRUE; - else if (FIXNUMP(hashtable->hash.threshold)) - over = i >= (cl_index)fix(hashtable->hash.threshold); - else if (type_of(hashtable->hash.threshold) == t_shortfloat) - over = i >= hashtable->hash.size * sf(hashtable->hash.threshold); - else if (type_of(hashtable->hash.threshold) == t_longfloat) - over = i >= hashtable->hash.size * lf(hashtable->hash.threshold); - else - FEerror("internal error, corrupted hashtable ~S", 1, hashtable); - if (over) + } else if (i >= hashtable->hash.size || + i >= (hashtable->hash.size * hashtable->hash.factor)) { ecl_extend_hashtable(hashtable); + } keylist = Cnil; for (p = keys + argno; p > keys; p--) keylist = CONS(p[-1], keylist); e = get_meth_hash(keys, argno, hashtable); diff --git a/src/c/hash.d b/src/c/hash.d index 3ef267fd4..57daf0304 100644 --- a/src/c/hash.d +++ b/src/c/hash.d @@ -200,8 +200,16 @@ BEGIN: #endif /* !ANSI */ case t_random: return h ^ x->random.value; - case t_package: /* These two should actually */ - case t_bitvector: /* have visible changes under equal */ + case t_bitvector: + /* Notice that we may round out some bits. We must do this + * because the fill pointer may be set in the middle of a byte. + * If so, the extra bits _must_ _not_ take part in the CRC, + * because otherwise we two bit arrays which are EQUAL might + * have different hash keys. */ + len = x->vector.fillp / 8; + buffer = x->vector.self.ch; + break; + case t_package: /* They should actually be same under equal */ default: return h ^ hash_eql(x); } @@ -339,7 +347,6 @@ void sethash(cl_object key, cl_object hashtable, cl_object value) { cl_index i; - bool over; struct ecl_hashtable_entry *e; assert_type_hash_table(hashtable); @@ -350,20 +357,10 @@ sethash(cl_object key, cl_object hashtable, cl_object value) goto OUTPUT; } i = hashtable->hash.entries + 1; - if (i >= hashtable->hash.size) - over = TRUE; - else if (FIXNUMP(hashtable->hash.threshold)) - over = i >= (cl_index)fix(hashtable->hash.threshold); - else if (type_of(hashtable->hash.threshold) == t_shortfloat) - over = i >= hashtable->hash.size * sf(hashtable->hash.threshold); - else if (type_of(hashtable->hash.threshold) == t_longfloat) - over = i >= hashtable->hash.size * lf(hashtable->hash.threshold); - else { - HASH_TABLE_UNLOCK(hashtable); - corrupted_hash(hashtable); - } - if (over) + if (i >= hashtable->hash.size || + i >= (hashtable->hash.size * hashtable->hash.factor)) { ecl_extend_hashtable(hashtable); + } add_new_to_hash(key, hashtable, value); OUTPUT: HASH_TABLE_UNLOCK(hashtable); @@ -388,13 +385,10 @@ ecl_extend_hashtable(cl_object hashtable) if (new_size <= old_size) new_size = old_size + 1; old = cl_alloc_object(t_hashtable); - old->hash = hashtable->hash; + *old = *hashtable; hashtable->hash.data = NULL; /* for GC sake */ + hashtable->hash.entries = 0; hashtable->hash.size = new_size; - if (FIXNUMP(hashtable->hash.threshold)) - hashtable->hash.threshold = - MAKE_FIXNUM(fix(hashtable->hash.threshold) + - (new_size - old->hash.size)); hashtable->hash.data = (struct ecl_hashtable_entry *) cl_alloc(new_size * sizeof(struct ecl_hashtable_entry)); for (i = 0; i < new_size; i++) { @@ -427,6 +421,9 @@ cl__make_hash_table(cl_object test, cl_object size, cl_object rehash_size, int htt; cl_index hsize; cl_object h; + double factor; + double delta; + cl_type t; if (test == @'eq' || test == SYM_FUN(@'eq')) htt = htt_eq; @@ -442,28 +439,30 @@ cl__make_hash_table(cl_object test, cl_object size, cl_object rehash_size, if (!FIXNUMP(size) || FIXNUM_MINUSP(size)) FEerror("~S is an illegal hash-table size.", 1, size); hsize = fix(size); - if ((FIXNUMP(rehash_size) && 0 <= fix(rehash_size)) || - (type_of(rehash_size) == t_shortfloat && 1.0 <= sf(rehash_size)) || - (type_of(rehash_size) == t_longfloat && 1.0 <= lf(rehash_size))) - ; - else + delta = 0; + t = type_of(rehash_size); + if (t == t_fixnum || t == t_shortfloat || t == t_longfloat) { + delta = number_to_double(rehash_size); + } + if (delta < 1 || delta > MOST_POSITIVE_FIXNUM) { FEerror("~S is an illegal hash-table rehash-size.", 1, rehash_size); - if ((FIXNUMP(rehash_threshold) && - 0 < fix(rehash_threshold) && fix(rehash_threshold) <= fix(size)) || - (type_of(rehash_threshold) == t_shortfloat && - 0.0 < sf(rehash_threshold) && sf(rehash_threshold) <= 1.0) || - (type_of(rehash_threshold) == t_longfloat && - 0.0 < lf(rehash_threshold) && lf(rehash_threshold) <= 1.0)) - ; - else + } + factor = -1.0; + t = type_of(rehash_threshold); + if (t == t_fixnum || t == t_ratio || t == t_shortfloat || t == t_longfloat) { + factor = number_to_double(rehash_threshold); + } + if (factor < 0.0 || factor > 1.0) { FEerror("~S is an illegal hash-table rehash-threshold.", 1, rehash_threshold); + } h = cl_alloc_object(t_hashtable); h->hash.test = htt; h->hash.size = hsize; h->hash.rehash_size = rehash_size; h->hash.threshold = rehash_threshold; + h->hash.factor = factor; h->hash.entries = 0; h->hash.data = NULL; /* for GC sake */ h->hash.data = (struct ecl_hashtable_entry *) @@ -551,6 +550,7 @@ cl_object cl_hash_table_test(cl_object ht) { cl_object output; + assert_type_hash_table(ht); switch(ht->hash.test) { case htt_eq: output = @'eq'; break; case htt_eql: output = @'eql'; break; @@ -565,6 +565,7 @@ cl_hash_table_test(cl_object ht) cl_object cl_hash_table_size(cl_object ht) { + assert_type_hash_table(ht); @(return MAKE_FIXNUM(ht->hash.size)) } @@ -622,7 +623,9 @@ cl_hash_table_rehash_threshold(cl_object ht) cl_object cl_sxhash(cl_object key) { - @(return (MAKE_FIXNUM(_hash_equal(~(cl_hashkey)0, 0, key) & 0x7fffffff))) + cl_index output = _hash_equal(~(cl_hashkey)0, 0, key); + const cl_index mask = (1 << (FIXNUM_BITS - 3)) - 1; + @(return MAKE_FIXNUM(output & mask)) } cl_object diff --git a/src/c/num_arith.d b/src/c/num_arith.d index a3b841563..dd97f008b 100644 --- a/src/c/num_arith.d +++ b/src/c/num_arith.d @@ -750,8 +750,10 @@ integer_divide(cl_object x, cl_object y) @(return MAKE_FIXNUM(0)) /* INV: get_gcd() checks types */ gcd = cl_va_arg(nums); - if (narg == 1) + if (narg == 1) { + assert_type_integer(gcd); @(return (number_minusp(gcd) ? number_negate(gcd) : gcd)) + } while (--narg) gcd = get_gcd(gcd, cl_va_arg(nums)); @(return gcd) @@ -907,7 +909,9 @@ one_minus(cl_object x) cl_object numi = cl_va_arg(nums); cl_object t = number_times(lcm, numi); cl_object g = get_gcd(numi, lcm); - lcm = number_divide(t, g); + if (g != MAKE_FIXNUM(0)) + lcm = number_divide(t, g); } + assert_type_integer(lcm); @(return (number_minusp(lcm) ? number_negate(lcm) : lcm)) @) diff --git a/src/c/num_sfun.d b/src/c/num_sfun.d index 2003a51ac..4e5fbcd58 100644 --- a/src/c/num_sfun.d +++ b/src/c/num_sfun.d @@ -106,7 +106,7 @@ cl_expt(cl_object x, cl_object y) case t_longfloat: return1(make_longfloat(1.0)); case t_complex: - z = cl_float(2, MAKE_FIXNUM(1), x->complex.real); + z = cl_expt(x->complex.real, y); z = make_complex(z, MAKE_FIXNUM(0)); return1(z); default: diff --git a/src/c/package.d b/src/c/package.d index 796de344e..f8a0166c0 100644 --- a/src/c/package.d +++ b/src/c/package.d @@ -91,6 +91,7 @@ make_package_hashtable() h->hash.size = hsize; h->hash.rehash_size = make_shortfloat(1.5); h->hash.threshold = make_shortfloat(0.7); + h->hash.factor = 0.7; h->hash.entries = 0; h->hash.data = NULL; /* for GC sake */ h->hash.data = (struct ecl_hashtable_entry *)cl_alloc(hsize * sizeof(struct ecl_hashtable_entry)); diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index f11bb3457..93df927d7 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -176,7 +176,7 @@ cl_symbols[] = { {"BOUNDP", CL_ORDINARY, cl_boundp, 1, OBJNULL}, {"BREAK", CL_ORDINARY, NULL, -1, OBJNULL}, {"BROADCAST-STREAM", CL_ORDINARY, NULL, -1, OBJNULL}, -{"BROADCAST-STREAM-STREAMS", CL_ORDINARY, NULL, -1, OBJNULL}, +{"BROADCAST-STREAM-STREAMS", CL_ORDINARY, cl_broadcast_stream_streams, 1, OBJNULL}, {"BUTLAST", CL_ORDINARY, cl_butlast, -1, OBJNULL}, {"BYTE", CL_ORDINARY, NULL, -1, OBJNULL}, {"BYTE-POSITION", CL_ORDINARY, NULL, -1, OBJNULL}, @@ -338,8 +338,8 @@ cl_symbols[] = { {"DYNAMIC-EXTENT", CL_ORDINARY, NULL, -1, OBJNULL}, {"ECASE", CL_ORDINARY, NULL, -1, OBJNULL}, {"ECHO-STREAM", CL_ORDINARY, NULL, -1, OBJNULL}, -{"ECHO-STREAM-INPUT-STREAM", CL_ORDINARY, NULL, -1, OBJNULL}, -{"ECHO-STREAM-OUTPUT-STREAM", CL_ORDINARY, NULL, -1, OBJNULL}, +{"ECHO-STREAM-INPUT-STREAM", CL_ORDINARY, cl_echo_stream_input_stream, 1, OBJNULL}, +{"ECHO-STREAM-OUTPUT-STREAM", CL_ORDINARY, cl_echo_stream_output_stream, 1, OBJNULL}, {"ED", CL_ORDINARY, NULL, -1, OBJNULL}, {"EIGHTH", CL_ORDINARY, cl_eighth, 1, OBJNULL}, {"ELT", CL_ORDINARY, cl_elt, 2, OBJNULL}, @@ -374,7 +374,7 @@ cl_symbols[] = { {"FILE-NAMESTRING", CL_ORDINARY, cl_file_namestring, 1, OBJNULL}, {"FILE-POSITION", CL_ORDINARY, cl_file_position, -1, OBJNULL}, {"FILE-STREAM", CL_ORDINARY, NULL, -1, OBJNULL}, -{"FILE-STRING-LENGTH", CL_ORDINARY, NULL, -1, OBJNULL}, +{"FILE-STRING-LENGTH", CL_ORDINARY, cl_file_string_length, 1, OBJNULL}, {"FILE-WRITE-DATE", CL_ORDINARY, cl_file_write_date, 1, OBJNULL}, {"FILL", CL_ORDINARY, NULL, -1, OBJNULL}, {"FILL-POINTER", CL_ORDINARY, cl_fill_pointer, 1, OBJNULL}, @@ -456,7 +456,7 @@ cl_symbols[] = { {"INTEGER-DECODE-FLOAT", CL_ORDINARY, cl_integer_decode_float, 1, OBJNULL}, {"INTEGER-LENGTH", CL_ORDINARY, cl_integer_length, 1, OBJNULL}, {"INTEGERP", CL_ORDINARY, cl_integerp, 1, OBJNULL}, -{"INTERACTIVE-STREAM-P", CL_ORDINARY, NULL, -1, OBJNULL}, +{"INTERACTIVE-STREAM-P", CL_ORDINARY, cl_interactive_stream_p, 1, OBJNULL}, {"INTERN", CL_ORDINARY, cl_intern, -1, OBJNULL}, {"INTERNAL-TIME-UNITS-PER-SECOND", CL_CONSTANT, NULL, -1, OBJNULL}, {"INTERSECTION", CL_ORDINARY, NULL, -1, OBJNULL}, @@ -806,7 +806,7 @@ cl_symbols[] = { {"STREAM-ELEMENT-TYPE", CL_ORDINARY, cl_stream_element_type, 1, OBJNULL}, {"STREAM-ERROR", CL_ORDINARY, NULL, -1, OBJNULL}, {"STREAM-ERROR-STREAM", CL_ORDINARY, NULL, -1, OBJNULL}, -{"STREAM-EXTERNAL-FORMAT", CL_ORDINARY, NULL, -1, OBJNULL}, +{"STREAM-EXTERNAL-FORMAT", CL_ORDINARY, cl_stream_external_format, 1, OBJNULL}, {"STREAMP", CL_ORDINARY, cl_streamp, 1, OBJNULL}, {"STRING", CL_ORDINARY, cl_string, 1, OBJNULL}, {"STRING-CAPITALIZE", CL_ORDINARY, cl_string_capitalize, -1, OBJNULL}, @@ -852,7 +852,7 @@ cl_symbols[] = { {"SYMBOL-VALUE", CL_ORDINARY, cl_symbol_value, 1, OBJNULL}, {"SYMBOLP", CL_ORDINARY, cl_symbolp, 1, OBJNULL}, {"SYNONYM-STREAM", CL_ORDINARY, NULL, -1, OBJNULL}, -{"SYNONYM-STREAM-SYMBOL", CL_ORDINARY, NULL, -1, OBJNULL}, +{"SYNONYM-STREAM-SYMBOL", CL_ORDINARY, cl_synonym_stream_symbol, 1, OBJNULL}, {"TAGBODY", CL_FORM, NULL, -1, OBJNULL}, {"TAILP", CL_ORDINARY, cl_tailp, 2, OBJNULL}, {"TAN", CL_ORDINARY, cl_tan, 1, OBJNULL}, @@ -870,8 +870,8 @@ cl_symbols[] = { {"TRUENAME", CL_ORDINARY, cl_truename, 1, OBJNULL}, {"TRUNCATE", CL_ORDINARY, cl_truncate, -1, OBJNULL}, {"TWO-WAY-STREAM", CL_ORDINARY, NULL, -1, OBJNULL}, -{"TWO-WAY-STREAM-INPUT-STREAM", CL_ORDINARY, NULL, -1, OBJNULL}, -{"TWO-WAY-STREAM-OUTPUT-STREAM", CL_ORDINARY, NULL, -1, OBJNULL}, +{"TWO-WAY-STREAM-INPUT-STREAM", CL_ORDINARY, cl_two_way_stream_input_stream, 1, OBJNULL}, +{"TWO-WAY-STREAM-OUTPUT-STREAM", CL_ORDINARY, cl_two_way_stream_output_stream, 1, OBJNULL}, {"TYPE", CL_ORDINARY, NULL, -1, OBJNULL}, {"TYPE-ERROR", CL_ORDINARY, NULL, -1, OBJNULL}, {"TYPE-ERROR-DATUM", CL_ORDINARY, NULL, -1, OBJNULL}, @@ -1179,16 +1179,17 @@ cl_symbols[] = { #endif #ifdef ECL_CLOS_STREAMS -{"STREAM-CLEAR-INPUT", CL_ORDINARY, NULL, -1, OBJNULL}, -{"STREAM-CLEAR-OUTPUT", CL_ORDINARY, NULL, -1, OBJNULL}, -{"STREAM-CLOSE", CL_ORDINARY, NULL, -1, OBJNULL}, -{"STREAM-FORCE-OUTPUT", CL_ORDINARY, NULL, -1, OBJNULL}, -{"STREAM-INPUT-P", CL_ORDINARY, NULL, -1, OBJNULL}, -{"STREAM-LISTEN", CL_ORDINARY, NULL, -1, OBJNULL}, -{"STREAM-OUTPUT-P", CL_ORDINARY, NULL, -1, OBJNULL}, -{"STREAM-READ-CHAR", CL_ORDINARY, NULL, -1, OBJNULL}, -{"STREAM-UNREAD-CHAR", CL_ORDINARY, NULL, -1, OBJNULL}, -{"STREAM-WRITE-CHAR", CL_ORDINARY, NULL, -1, OBJNULL}, +{EXT_ "STREAM-CLEAR-INPUT", EXT_ORDINARY, NULL, -1, OBJNULL}, +{EXT_ "STREAM-CLEAR-OUTPUT", EXT_ORDINARY, NULL, -1, OBJNULL}, +{EXT_ "STREAM-CLOSE", EXT_ORDINARY, NULL, -1, OBJNULL}, +{EXT_ "STREAM-FORCE-OUTPUT", EXT_ORDINARY, NULL, -1, OBJNULL}, +{EXT_ "STREAM-INPUT-P", EXT_ORDINARY, NULL, -1, OBJNULL}, +{EXT_ "STREAM-INTERACTIVE-P", EXT_ORDINARY, NULL, -1, OBJNULL}, +{EXT_ "STREAM-LISTEN", EXT_ORDINARY, NULL, -1, OBJNULL}, +{EXT_ "STREAM-OUTPUT-P", EXT_ORDINARY, NULL, -1, OBJNULL}, +{EXT_ "STREAM-READ-CHAR", EXT_ORDINARY, NULL, -1, OBJNULL}, +{EXT_ "STREAM-UNREAD-CHAR", EXT_ORDINARY, NULL, -1, OBJNULL}, +{EXT_ "STREAM-WRITE-CHAR", EXT_ORDINARY, NULL, -1, OBJNULL}, #endif #ifdef PDE diff --git a/src/c/typespec.d b/src/c/typespec.d index 1ae2f628b..8810f2a4a 100644 --- a/src/c/typespec.d +++ b/src/c/typespec.d @@ -181,13 +181,6 @@ assert_type_proper_list(cl_object p) FEcircular_list(p); } -void -assert_type_stream(cl_object p) -{ - if (type_of(p) != t_stream) - FEwrong_type_argument(@'stream', p); -} - void assert_type_readtable(cl_object p) { diff --git a/src/clos/conditions.lsp b/src/clos/conditions.lsp index 226be9878..9524dd6c0 100644 --- a/src/clos/conditions.lsp +++ b/src/clos/conditions.lsp @@ -569,7 +569,8 @@ returns with NIL." (cell-error-name condition))))) (define-condition arithmetic-error (error) - ((operation :INITARG :OPERATION :READER arithmetic-error-operation))) + ((operation :INITARG :OPERATION :READER arithmetic-error-operation) + (operands :INITARG :OPERANDS :INITFORM '() :READER arithmetic-error-operands))) (define-condition division-by-zero (arithmetic-error) ()) @@ -658,14 +659,12 @@ returns with NIL." (list (car annotated-case) (let ((body (cdddr annotated-case))) `(return-from ,tag - ,(cond ((caddr annotated-case) - `(let ((,(caaddr annotated-case) - ,var)) - ,@body)) - ((not (cdr body)) - (car body)) - (t - `(progn ,@body))))))) + ,(if (caddr annotated-case) + `(let ((,(caaddr annotated-case) + ,var)) + ,@body) + ;; We must allow declarations! + `(locally ,@body)))))) annotated-cases)))))))) (defmacro ignore-errors (&rest forms) diff --git a/src/clos/kernel.lsp b/src/clos/kernel.lsp index 5a1e6c4eb..2b2ef3769 100644 --- a/src/clos/kernel.lsp +++ b/src/clos/kernel.lsp @@ -86,7 +86,7 @@ ;; use fixnums as limits for efficiency: :size *default-method-cache-size* :rehash-size #.(/ *default-method-cache-size* 2) - :rehash-threshold #.(/ *default-method-cache-size* 2))) + :rehash-threshold 0.5s0)) (spec-list :initform nil :accessor generic-function-spec-list) (method-combination :initarg :method-combination :initform '(standard) @@ -199,7 +199,7 @@ ;; use fixnums as limits for efficiency: :size *default-method-cache-size* :rehash-size #.(/ *default-method-cache-size* 2) - :rehash-threshold #.(/ *default-method-cache-size* 2)))) + :rehash-threshold 0.5s0))) (declare (type standard-object gfun)) ;; create a new gfun (setf (generic-function-name gfun) name diff --git a/src/cmp/sysfun.lsp b/src/cmp/sysfun.lsp index 17dff379f..0ee3352cf 100644 --- a/src/cmp/sysfun.lsp +++ b/src/cmp/sysfun.lsp @@ -647,17 +647,19 @@ (INTEGER-LENGTH (T) FIXNUM) (si::BIT-ARRAY-OP nil T) (ZEROP (T) T NIL T - :inline-always ((t) :bool nil nil "number_compare(MAKE_FIXNUM(0),#0)==0") + :inline-always ((t) :bool nil nil "number_zerop(#0)") :inline-always ((fixnum-float) :bool nil nil "(#0)==0")) (PLUSP (T) T NIL T - :inline-always ((t) :bool nil nil "number_compare(MAKE_FIXNUM(0),#0)<0") + :inline-always ((t) :bool nil nil "number_plusp(#0)") :inline-always ((fixnum-float) :bool nil nil "(#0)>0")) (MINUSP (T) T NIL T - :inline-always ((t) :bool nil nil "number_compare(MAKE_FIXNUM(0),#0)>0") + :inline-always ((t) :bool nil nil "number_minusp(#0)") :inline-always ((fixnum-float) :bool nil nil "(#0)<0")) (ODDP (T) T NIL T + :inline-always ((t) :bool nil nil "number_oddp(#0)") :inline-always ((fixnum fixnum) :bool nil nil "(#0) & 1")) (EVENP (T) T NIL T + :inline-always ((t) :bool nil nil "number_evenp(#0)") :inline-always ((fixnum fixnum) :bool nil nil "~(#0) & 1")) (RANDOM (T *) T) (MAKE-RANDOM-STATE (*) T) diff --git a/src/h/external.h b/src/h/external.h index c5397759c..7d97d12e9 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -488,8 +488,13 @@ extern cl_object ecl_make_foreign_data(cl_object tag, cl_index size, void *data) /* file.c */ extern cl_object cl_make_synonym_stream(cl_object sym); +extern cl_object cl_synonym_stream_symbol(cl_object strm); extern cl_object cl_make_two_way_stream(cl_object strm1, cl_object strm2); +extern cl_object cl_two_way_stream_input_stream(cl_object strm); +extern cl_object cl_two_way_stream_output_stream(cl_object strm); extern cl_object cl_make_echo_stream(cl_object strm1, cl_object strm2); +extern cl_object cl_echo_stream_input_stream(cl_object strm); +extern cl_object cl_echo_stream_output_stream(cl_object strm); extern cl_object cl_make_string_output_stream(); extern cl_object cl_get_output_stream_string(cl_object strm); extern cl_object si_output_stream_string(cl_object strm); @@ -497,20 +502,25 @@ extern cl_object cl_streamp(cl_object strm); extern cl_object cl_input_stream_p(cl_object strm); extern cl_object cl_output_stream_p(cl_object strm); extern cl_object cl_stream_element_type(cl_object strm); +extern cl_object cl_stream_external_format(cl_object strm); extern cl_object cl_file_length(cl_object strm); extern cl_object si_get_string_input_stream_index(cl_object strm); extern cl_object si_make_string_output_stream_from_string(cl_object strng); extern cl_object si_copy_stream(cl_object in, cl_object out); extern cl_object cl_open_stream_p(cl_object strm); extern cl_object cl_make_broadcast_stream _ARGS((int narg, ...)); +extern cl_object cl_broadcast_stream_streams(cl_object strm); extern cl_object cl_make_concatenated_stream _ARGS((int narg, ...)); +extern cl_object cl_concatenated_stream_streams(cl_object strm); 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 cl_file_string_length(cl_object string); 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 cl_object si_file_column(cl_object strm); +extern cl_object cl_interactive_stream_p(cl_object strm); extern bool input_stream_p(cl_object strm); extern bool output_stream_p(cl_object strm); @@ -518,7 +528,6 @@ extern cl_object stream_element_type(cl_object strm); extern cl_object open_stream(cl_object fn, enum ecl_smmode smm, cl_object if_exists, cl_object if_does_not_exist); extern void close_stream(cl_object strm, bool abort_flag); extern cl_object make_two_way_stream(cl_object istrm, cl_object ostrm); -extern cl_object make_echo_stream(cl_object istrm, cl_object ostrm); extern cl_object make_string_input_stream(cl_object strng, cl_index istart, cl_index iend); extern cl_object make_string_output_stream(cl_index line_length); extern cl_object make_string_output_stream_from_string(cl_object s); diff --git a/src/h/object.h b/src/h/object.h index 56887e38a..8efc276cd 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -184,10 +184,11 @@ struct ecl_hashtable_entry { /* hash table entry */ struct ecl_hashtable { /* hash table header */ HEADER2(test,lockable); struct ecl_hashtable_entry *data; /* pointer to the hash table */ - cl_object rehash_size; /* rehash size */ - cl_object threshold; /* rehash threshold */ cl_index entries; /* number of entries */ cl_index size; /* hash table size */ + cl_object rehash_size; /* rehash size */ + cl_object threshold; /* rehash threshold */ + double factor; /* cached value of threshold */ #ifdef ECL_THREADS pthread_mutex_t lock; /* mutex to prevent race conditions */ #endif diff --git a/src/lsp/numlib.lsp b/src/lsp/numlib.lsp index 4043b6453..0d970724f 100644 --- a/src/lsp/numlib.lsp +++ b/src/lsp/numlib.lsp @@ -18,7 +18,7 @@ "Args: (integer) Returns the integer square root of INTEGER." (unless (and (integerp i) (>= i 0)) - (error "~S is not a non-negative integer." i)) + (error 'type-error :datum i :expected-type 'unsigned-byte)) (if (zerop i) 0 (let ((n (integer-length i)))