mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-02 07:30:55 -08:00
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.
This commit is contained in:
jjgarcia
parent
a583081e53
commit
6d1ec50d38
16 changed files with 259 additions and 134 deletions
|
|
@ -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:
|
||||
=====
|
||||
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
||||
|
|
|
|||
179
src/c/file.d
179
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)
|
||||
{
|
||||
|
|
|
|||
16
src/c/gfun.d
16
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);
|
||||
|
|
|
|||
73
src/c/hash.d
73
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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
@)
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -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));
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
{
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue