#include <time.h>
#include <setjmp.h>
+#include <intprops.h>
+
#include "lisp.h"
#include "commands.h"
#include "character.h"
static Lisp_Object Qwidget_type;
static Lisp_Object Qcodeset, Qdays, Qmonths, Qpaper;
+static Lisp_Object Qmd5, Qsha1, Qsha224, Qsha256, Qsha384, Qsha512;
+
static int internal_equal (Lisp_Object , Lisp_Object, int, int);
#ifndef HAVE_UNISTD_H
return lispy_val;
}
\f
+/* Heuristic on how many iterations of a tight loop can be safely done
+ before it's time to do a QUIT. This must be a power of 2. */
+enum { QUIT_COUNT_HEURISTIC = 1 << 16 };
+
/* Random data-structure functions */
DEFUN ("length", Flength, Slength, 1, 1, 0,
(register Lisp_Object sequence)
{
register Lisp_Object val;
- register int i;
if (STRINGP (sequence))
XSETFASTINT (val, SCHARS (sequence));
XSETFASTINT (val, ASIZE (sequence) & PSEUDOVECTOR_SIZE_MASK);
else if (CONSP (sequence))
{
- i = 0;
- while (CONSP (sequence))
+ EMACS_INT i = 0;
+
+ do
{
- sequence = XCDR (sequence);
++i;
-
- if (!CONSP (sequence))
- break;
-
+ if ((i & (QUIT_COUNT_HEURISTIC - 1)) == 0)
+ {
+ if (MOST_POSITIVE_FIXNUM < i)
+ error ("List too long");
+ QUIT;
+ }
sequence = XCDR (sequence);
- ++i;
- QUIT;
}
+ while (CONSP (sequence));
CHECK_LIST_END (sequence, sequence);
which is at least the number of distinct elements. */)
(Lisp_Object list)
{
- Lisp_Object tail, halftail, length;
- int len = 0;
+ Lisp_Object tail, halftail;
+ double hilen = 0;
+ uintmax_t lolen = 1;
+
+ if (! CONSP (list))
+ return make_number (0);
/* halftail is used to detect circular lists. */
- halftail = list;
- for (tail = list; CONSP (tail); tail = XCDR (tail))
+ for (tail = halftail = list; ; )
{
- if (EQ (tail, halftail) && len != 0)
+ tail = XCDR (tail);
+ if (! CONSP (tail))
+ break;
+ if (EQ (tail, halftail))
break;
- len++;
- if ((len & 1) == 0)
- halftail = XCDR (halftail);
+ lolen++;
+ if ((lolen & 1) == 0)
+ {
+ halftail = XCDR (halftail);
+ if ((lolen & (QUIT_COUNT_HEURISTIC - 1)) == 0)
+ {
+ QUIT;
+ if (lolen == 0)
+ hilen += UINTMAX_MAX + 1.0;
+ }
+ }
}
- XSETINT (length, len);
- return length;
+ /* If the length does not fit into a fixnum, return a float.
+ On all known practical machines this returns an upper bound on
+ the true length. */
+ return hilen ? make_float (hilen + lolen) : make_fixnum_or_float (lolen);
}
DEFUN ("string-bytes", Fstring_bytes, Sstring_bytes, 1, 1, 0,
return i1 < SCHARS (s2) ? Qt : Qnil;
}
\f
-static Lisp_Object concat (size_t nargs, Lisp_Object *args,
+static Lisp_Object concat (ptrdiff_t nargs, Lisp_Object *args,
enum Lisp_Type target_type, int last_special);
/* ARGSUSED */
Each argument may be a list, vector or string.
The last argument is not copied, just used as the tail of the new list.
usage: (append &rest SEQUENCES) */)
- (size_t nargs, Lisp_Object *args)
+ (ptrdiff_t nargs, Lisp_Object *args)
{
return concat (nargs, args, Lisp_Cons, 1);
}
The result is a string whose elements are the elements of all the arguments.
Each argument may be a string or a list or vector of characters (integers).
usage: (concat &rest SEQUENCES) */)
- (size_t nargs, Lisp_Object *args)
+ (ptrdiff_t nargs, Lisp_Object *args)
{
return concat (nargs, args, Lisp_String, 0);
}
The result is a vector whose elements are the elements of all the arguments.
Each argument may be a list, vector or string.
usage: (vconcat &rest SEQUENCES) */)
- (size_t nargs, Lisp_Object *args)
+ (ptrdiff_t nargs, Lisp_Object *args)
{
return concat (nargs, args, Lisp_Vectorlike, 0);
}
if (BOOL_VECTOR_P (arg))
{
Lisp_Object val;
- int size_in_chars
+ ptrdiff_t size_in_chars
= ((XBOOL_VECTOR (arg)->size + BOOL_VECTOR_BITS_PER_CHAR - 1)
/ BOOL_VECTOR_BITS_PER_CHAR);
a string and has text properties to be copied. */
struct textprop_rec
{
- int argnum; /* refer to ARGS (arguments of `concat') */
+ ptrdiff_t argnum; /* refer to ARGS (arguments of `concat') */
EMACS_INT from; /* refer to ARGS[argnum] (argument string) */
EMACS_INT to; /* refer to VAL (the target string) */
};
static Lisp_Object
-concat (size_t nargs, Lisp_Object *args,
+concat (ptrdiff_t nargs, Lisp_Object *args,
enum Lisp_Type target_type, int last_special)
{
Lisp_Object val;
EMACS_INT toindex_byte = 0;
register EMACS_INT result_len;
register EMACS_INT result_len_byte;
- register size_t argnum;
+ ptrdiff_t argnum;
Lisp_Object last_tail;
Lisp_Object prev;
int some_multibyte;
here, and copy the text properties after the concatenation. */
struct textprop_rec *textprops = NULL;
/* Number of elements in textprops. */
- int num_textprops = 0;
+ ptrdiff_t num_textprops = 0;
USE_SAFE_ALLOCA;
tail = Qnil;
as well as the number of characters. */
EMACS_INT i;
Lisp_Object ch;
+ int c;
EMACS_INT this_len_byte;
if (VECTORP (this) || COMPILEDP (this))
{
ch = AREF (this, i);
CHECK_CHARACTER (ch);
- this_len_byte = CHAR_BYTES (XINT (ch));
+ c = XFASTINT (ch);
+ this_len_byte = CHAR_BYTES (c);
result_len_byte += this_len_byte;
- if (! ASCII_CHAR_P (XINT (ch)) && ! CHAR_BYTE8_P (XINT (ch)))
+ if (! ASCII_CHAR_P (c) && ! CHAR_BYTE8_P (c))
some_multibyte = 1;
}
else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size > 0)
{
ch = XCAR (this);
CHECK_CHARACTER (ch);
- this_len_byte = CHAR_BYTES (XINT (ch));
+ c = XFASTINT (ch);
+ this_len_byte = CHAR_BYTES (c);
result_len_byte += this_len_byte;
- if (! ASCII_CHAR_P (XINT (ch)) && ! CHAR_BYTE8_P (XINT (ch)))
+ if (! ASCII_CHAR_P (c) && ! CHAR_BYTE8_P (c))
some_multibyte = 1;
}
else if (STRINGP (this))
}
result_len += len;
- if (result_len < 0)
- error ("String overflow");
+ if (STRING_BYTES_BOUND < result_len)
+ string_overflow ();
}
if (! some_multibyte)
{
int c;
if (STRING_MULTIBYTE (this))
- {
- FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, this,
- thisindex,
- thisindex_byte);
- XSETFASTINT (elt, c);
- }
+ FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, this,
+ thisindex,
+ thisindex_byte);
else
{
- XSETFASTINT (elt, SREF (this, thisindex)); thisindex++;
- if (some_multibyte
- && !ASCII_CHAR_P (XINT (elt))
- && XINT (elt) < 0400)
- {
- c = BYTE8_TO_CHAR (XINT (elt));
- XSETINT (elt, c);
- }
+ c = SREF (this, thisindex); thisindex++;
+ if (some_multibyte && !ASCII_CHAR_P (c))
+ c = BYTE8_TO_CHAR (c);
}
+ XSETFASTINT (elt, c);
}
else if (BOOL_VECTOR_P (this))
{
}
else
{
- CHECK_NUMBER (elt);
+ int c;
+ CHECK_CHARACTER (elt);
+ c = XFASTINT (elt);
if (some_multibyte)
- toindex_byte += CHAR_STRING (XINT (elt),
- SDATA (val) + toindex_byte);
+ toindex_byte += CHAR_STRING (c, SDATA (val) + toindex_byte);
else
- SSET (val, toindex_byte++, XINT (elt));
+ SSET (val, toindex_byte++, c);
toindex++;
}
}
doc: /* Take cdr N times on LIST, return the result. */)
(Lisp_Object n, Lisp_Object list)
{
- register int i, num;
+ EMACS_INT i, num;
CHECK_NUMBER (n);
num = XINT (n);
for (i = 0; i < num && !NILP (list); i++)
Lisp_Object front, back;
register Lisp_Object len, tem;
struct gcpro gcpro1, gcpro2;
- register int length;
+ EMACS_INT length;
front = list;
len = Flength (list);
(Lisp_Object array, Lisp_Object item)
{
register EMACS_INT size, idx;
- int charval;
if (VECTORP (array))
{
else if (STRINGP (array))
{
register unsigned char *p = SDATA (array);
- CHECK_NUMBER (item);
- charval = XINT (item);
+ int charval;
+ CHECK_CHARACTER (item);
+ charval = XFASTINT (item);
size = SCHARS (array);
if (STRING_MULTIBYTE (array))
{
unsigned char str[MAX_MULTIBYTE_LENGTH];
int len = CHAR_STRING (charval, str);
EMACS_INT size_byte = SBYTES (array);
- unsigned char *p1 = p, *endp = p + size_byte;
- int i;
- if (size != size_byte)
- while (p1 < endp)
- {
- int this_len = BYTES_BY_CHAR_HEAD (*p1);
- if (len != this_len)
- error ("Attempt to change byte length of a string");
- p1 += this_len;
- }
- for (i = 0; i < size_byte; i++)
- *p++ = str[i % len];
+ if (INT_MULTIPLY_OVERFLOW (SCHARS (array), len)
+ || SCHARS (array) * len != size_byte)
+ error ("Attempt to change byte length of a string");
+ for (idx = 0; idx < size_byte; idx++)
+ *p++ = str[idx % len];
}
else
for (idx = 0; idx < size; idx++)
else if (BOOL_VECTOR_P (array))
{
register unsigned char *p = XBOOL_VECTOR (array)->data;
- int size_in_chars
- = ((XBOOL_VECTOR (array)->size + BOOL_VECTOR_BITS_PER_CHAR - 1)
+ EMACS_INT size_in_chars;
+ size = XBOOL_VECTOR (array)->size;
+ size_in_chars
+ = ((size + BOOL_VECTOR_BITS_PER_CHAR - 1)
/ BOOL_VECTOR_BITS_PER_CHAR);
- charval = (! NILP (item) ? -1 : 0);
- for (idx = 0; idx < size_in_chars - 1; idx++)
- p[idx] = charval;
- if (idx < size_in_chars)
+ if (size_in_chars)
{
- /* Mask out bits beyond the vector size. */
- if (XBOOL_VECTOR (array)->size % BOOL_VECTOR_BITS_PER_CHAR)
- charval &= (1 << (XBOOL_VECTOR (array)->size % BOOL_VECTOR_BITS_PER_CHAR)) - 1;
- p[idx] = charval;
+ memset (p, ! NILP (item) ? -1 : 0, size_in_chars);
+
+ /* Clear any extraneous bits in the last byte. */
+ p[size_in_chars - 1] &= (1 << (size % BOOL_VECTOR_BITS_PER_CHAR)) - 1;
}
}
else
doc: /* Concatenate any number of lists by altering them.
Only the last argument is not altered, and need not be a list.
usage: (nconc &rest LISTS) */)
- (size_t nargs, Lisp_Object *args)
+ (ptrdiff_t nargs, Lisp_Object *args)
{
- register size_t argnum;
+ ptrdiff_t argnum;
register Lisp_Object tail, tem, val;
val = tail = Qnil;
{
for (i = 0; i < leni; i++)
{
- int byte;
+ unsigned char byte;
byte = XBOOL_VECTOR (seq)->data[i / BOOL_VECTOR_BITS_PER_CHAR];
dummy = (byte & (1 << (i % BOOL_VECTOR_BITS_PER_CHAR))) ? Qt : Qnil;
dummy = call1 (fn, dummy);
{
Lisp_Object len;
register EMACS_INT leni;
- int nargs;
+ ptrdiff_t i, nargs;
register Lisp_Object *args;
- register EMACS_INT i;
struct gcpro gcpro1;
Lisp_Object ret;
USE_SAFE_ALLOCA;
while (loads-- > 0)
{
- Lisp_Object load = (NILP (use_floats) ?
- make_number ((int) (100.0 * load_ave[loads]))
+ Lisp_Object load = (NILP (use_floats)
+ ? make_number (100.0 * load_ave[loads])
: make_float (load_ave[loads]));
ret = Fcons (load, ret);
}
If FILENAME is omitted, the printname of FEATURE is used as the file name,
and `load' will try to load this name appended with the suffix `.elc' or
`.el', in that order. The name without appended suffix will not be used.
+If your system supports it, `.elc.gz' and `.el.gz' files will also be
+considered. See `get-load-suffixes' for the complete list of suffixes.
If the optional third argument NOERROR is non-nil,
then return nil if the file is not found instead of signaling an error.
Normally the return value is FEATURE.
doc: /* Apply the value of WIDGET's PROPERTY to the widget itself.
ARGS are passed as extra arguments to the function.
usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
- (size_t nargs, Lisp_Object *args)
+ (ptrdiff_t nargs, Lisp_Object *args)
{
/* This function can GC. */
Lisp_Object newargs[3];
/* Function prototypes. */
static struct Lisp_Hash_Table *check_hash_table (Lisp_Object);
-static size_t get_key_arg (Lisp_Object, size_t, Lisp_Object *, char *);
+static ptrdiff_t get_key_arg (Lisp_Object, ptrdiff_t, Lisp_Object *, char *);
static void maybe_resize_hash_table (struct Lisp_Hash_Table *);
-static int cmpfn_eql (struct Lisp_Hash_Table *, Lisp_Object, unsigned,
- Lisp_Object, unsigned);
-static int cmpfn_equal (struct Lisp_Hash_Table *, Lisp_Object, unsigned,
- Lisp_Object, unsigned);
-static int cmpfn_user_defined (struct Lisp_Hash_Table *, Lisp_Object,
- unsigned, Lisp_Object, unsigned);
-static unsigned hashfn_eq (struct Lisp_Hash_Table *, Lisp_Object);
-static unsigned hashfn_eql (struct Lisp_Hash_Table *, Lisp_Object);
-static unsigned hashfn_equal (struct Lisp_Hash_Table *, Lisp_Object);
-static unsigned hashfn_user_defined (struct Lisp_Hash_Table *,
- Lisp_Object);
-static unsigned sxhash_string (unsigned char *, int);
-static unsigned sxhash_list (Lisp_Object, int);
-static unsigned sxhash_vector (Lisp_Object, int);
-static unsigned sxhash_bool_vector (Lisp_Object);
static int sweep_weak_table (struct Lisp_Hash_Table *, int);
/* Value is the next integer I >= N, N >= 0 which is "almost" a prime
number. */
-int
-next_almost_prime (int n)
+EMACS_INT
+next_almost_prime (EMACS_INT n)
{
- if (n % 2 == 0)
- n += 1;
- if (n % 3 == 0)
- n += 2;
- if (n % 7 == 0)
- n += 4;
- return n;
+ for (n |= 1; ; n += 2)
+ if (n % 3 != 0 && n % 5 != 0 && n % 7 != 0)
+ return n;
}
0. This function is used to extract a keyword/argument pair from
a DEFUN parameter list. */
-static size_t
-get_key_arg (Lisp_Object key, size_t nargs, Lisp_Object *args, char *used)
+static ptrdiff_t
+get_key_arg (Lisp_Object key, ptrdiff_t nargs, Lisp_Object *args, char *used)
{
- size_t i;
+ ptrdiff_t i;
for (i = 1; i < nargs; i++)
if (!used[i - 1] && EQ (args[i - 1], key))
vector that are not copied from VEC are set to INIT. */
Lisp_Object
-larger_vector (Lisp_Object vec, int new_size, Lisp_Object init)
+larger_vector (Lisp_Object vec, EMACS_INT new_size, Lisp_Object init)
{
struct Lisp_Vector *v;
- int i, old_size;
+ EMACS_INT i, old_size;
xassert (VECTORP (vec));
old_size = ASIZE (vec);
KEY2 are the same. */
static int
-cmpfn_eql (struct Lisp_Hash_Table *h, Lisp_Object key1, unsigned int hash1, Lisp_Object key2, unsigned int hash2)
+cmpfn_eql (struct Lisp_Hash_Table *h,
+ Lisp_Object key1, EMACS_UINT hash1,
+ Lisp_Object key2, EMACS_UINT hash2)
{
return (FLOATP (key1)
&& FLOATP (key2)
KEY2 are the same. */
static int
-cmpfn_equal (struct Lisp_Hash_Table *h, Lisp_Object key1, unsigned int hash1, Lisp_Object key2, unsigned int hash2)
+cmpfn_equal (struct Lisp_Hash_Table *h,
+ Lisp_Object key1, EMACS_UINT hash1,
+ Lisp_Object key2, EMACS_UINT hash2)
{
return hash1 == hash2 && !NILP (Fequal (key1, key2));
}
if KEY1 and KEY2 are the same. */
static int
-cmpfn_user_defined (struct Lisp_Hash_Table *h, Lisp_Object key1, unsigned int hash1, Lisp_Object key2, unsigned int hash2)
+cmpfn_user_defined (struct Lisp_Hash_Table *h,
+ Lisp_Object key1, EMACS_UINT hash1,
+ Lisp_Object key2, EMACS_UINT hash2)
{
if (hash1 == hash2)
{
`eq' to compare keys. The hash code returned is guaranteed to fit
in a Lisp integer. */
-static unsigned
+static EMACS_UINT
hashfn_eq (struct Lisp_Hash_Table *h, Lisp_Object key)
{
- unsigned hash = XUINT (key) ^ XTYPE (key);
+ EMACS_UINT hash = XUINT (key) ^ XTYPE (key);
xassert ((hash & ~INTMASK) == 0);
return hash;
}
`eql' to compare keys. The hash code returned is guaranteed to fit
in a Lisp integer. */
-static unsigned
+static EMACS_UINT
hashfn_eql (struct Lisp_Hash_Table *h, Lisp_Object key)
{
- unsigned hash;
+ EMACS_UINT hash;
if (FLOATP (key))
hash = sxhash (key, 0);
else
`equal' to compare keys. The hash code returned is guaranteed to fit
in a Lisp integer. */
-static unsigned
+static EMACS_UINT
hashfn_equal (struct Lisp_Hash_Table *h, Lisp_Object key)
{
- unsigned hash = sxhash (key, 0);
+ EMACS_UINT hash = sxhash (key, 0);
xassert ((hash & ~INTMASK) == 0);
return hash;
}
user-defined function to compare keys. The hash code returned is
guaranteed to fit in a Lisp integer. */
-static unsigned
+static EMACS_UINT
hashfn_user_defined (struct Lisp_Hash_Table *h, Lisp_Object key)
{
Lisp_Object args[2], hash;
{
struct Lisp_Hash_Table *h;
Lisp_Object table;
- int index_size, i, sz;
+ EMACS_INT index_size, i, sz;
+ double index_float;
/* Preconditions. */
xassert (SYMBOLP (test));
xassert (INTEGERP (size) && XINT (size) >= 0);
xassert ((INTEGERP (rehash_size) && XINT (rehash_size) > 0)
- || (FLOATP (rehash_size) && XFLOATINT (rehash_size) > 1.0));
+ || (FLOATP (rehash_size) && 1 < XFLOAT_DATA (rehash_size)));
xassert (FLOATP (rehash_threshold)
- && XFLOATINT (rehash_threshold) > 0
- && XFLOATINT (rehash_threshold) <= 1.0);
+ && 0 < XFLOAT_DATA (rehash_threshold)
+ && XFLOAT_DATA (rehash_threshold) <= 1.0);
if (XFASTINT (size) == 0)
size = make_number (1);
+ sz = XFASTINT (size);
+ index_float = sz / XFLOAT_DATA (rehash_threshold);
+ index_size = (index_float < MOST_POSITIVE_FIXNUM + 1
+ ? next_almost_prime (index_float)
+ : MOST_POSITIVE_FIXNUM + 1);
+ if (MOST_POSITIVE_FIXNUM < max (index_size, 2 * sz))
+ error ("Hash table too large");
+
/* Allocate a table and initialize it. */
h = allocate_hash_table ();
/* Initialize hash table slots. */
- sz = XFASTINT (size);
-
h->test = test;
if (EQ (test, Qeql))
{
h->key_and_value = Fmake_vector (make_number (2 * sz), Qnil);
h->hash = Fmake_vector (size, Qnil);
h->next = Fmake_vector (size, Qnil);
- /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
- index_size = next_almost_prime ((int) (sz / XFLOATINT (rehash_threshold)));
h->index = Fmake_vector (make_number (index_size), Qnil);
/* Set up the free list. */
/* Resize hash table H if it's too full. If H cannot be resized
because it's already too large, throw an error. */
-static INLINE void
+static inline void
maybe_resize_hash_table (struct Lisp_Hash_Table *h)
{
if (NILP (h->next_free))
{
- int old_size = HASH_TABLE_SIZE (h);
- int i, new_size, index_size;
+ EMACS_INT old_size = HASH_TABLE_SIZE (h);
+ EMACS_INT i, new_size, index_size;
EMACS_INT nsize;
+ double index_float;
if (INTEGERP (h->rehash_size))
new_size = old_size + XFASTINT (h->rehash_size);
else
- new_size = old_size * XFLOATINT (h->rehash_size);
- new_size = max (old_size + 1, new_size);
- index_size = next_almost_prime ((int)
- (new_size
- / XFLOATINT (h->rehash_threshold)));
- /* Assignment to EMACS_INT stops GCC whining about limited range
- of data type. */
+ {
+ double float_new_size = old_size * XFLOAT_DATA (h->rehash_size);
+ if (float_new_size < MOST_POSITIVE_FIXNUM + 1)
+ {
+ new_size = float_new_size;
+ if (new_size <= old_size)
+ new_size = old_size + 1;
+ }
+ else
+ new_size = MOST_POSITIVE_FIXNUM + 1;
+ }
+ index_float = new_size / XFLOAT_DATA (h->rehash_threshold);
+ index_size = (index_float < MOST_POSITIVE_FIXNUM + 1
+ ? next_almost_prime (index_float)
+ : MOST_POSITIVE_FIXNUM + 1);
nsize = max (index_size, 2 * new_size);
if (nsize > MOST_POSITIVE_FIXNUM)
error ("Hash table too large to resize");
for (i = 0; i < old_size; ++i)
if (!NILP (HASH_HASH (h, i)))
{
- unsigned hash_code = XUINT (HASH_HASH (h, i));
- int start_of_bucket = hash_code % ASIZE (h->index);
+ EMACS_UINT hash_code = XUINT (HASH_HASH (h, i));
+ EMACS_INT start_of_bucket = hash_code % ASIZE (h->index);
HASH_NEXT (h, i) = HASH_INDEX (h, start_of_bucket);
HASH_INDEX (h, start_of_bucket) = make_number (i);
}
the hash code of KEY. Value is the index of the entry in H
matching KEY, or -1 if not found. */
-int
-hash_lookup (struct Lisp_Hash_Table *h, Lisp_Object key, unsigned int *hash)
+EMACS_INT
+hash_lookup (struct Lisp_Hash_Table *h, Lisp_Object key, EMACS_UINT *hash)
{
- unsigned hash_code;
- int start_of_bucket;
+ EMACS_UINT hash_code;
+ EMACS_INT start_of_bucket;
Lisp_Object idx;
hash_code = h->hashfn (h, key);
/* We need not gcpro idx since it's either an integer or nil. */
while (!NILP (idx))
{
- int i = XFASTINT (idx);
+ EMACS_INT i = XFASTINT (idx);
if (EQ (key, HASH_KEY (h, i))
|| (h->cmpfn
&& h->cmpfn (h, key, hash_code,
HASH is a previously computed hash code of KEY.
Value is the index of the entry in H matching KEY. */
-int
-hash_put (struct Lisp_Hash_Table *h, Lisp_Object key, Lisp_Object value, unsigned int hash)
+EMACS_INT
+hash_put (struct Lisp_Hash_Table *h, Lisp_Object key, Lisp_Object value,
+ EMACS_UINT hash)
{
- int start_of_bucket, i;
+ EMACS_INT start_of_bucket, i;
xassert ((hash & ~INTMASK) == 0);
static void
hash_remove_from_table (struct Lisp_Hash_Table *h, Lisp_Object key)
{
- unsigned hash_code;
- int start_of_bucket;
+ EMACS_UINT hash_code;
+ EMACS_INT start_of_bucket;
Lisp_Object idx, prev;
hash_code = h->hashfn (h, key);
/* We need not gcpro idx, prev since they're either integers or nil. */
while (!NILP (idx))
{
- int i = XFASTINT (idx);
+ EMACS_INT i = XFASTINT (idx);
if (EQ (key, HASH_KEY (h, i))
|| (h->cmpfn
{
if (h->count > 0)
{
- int i, size = HASH_TABLE_SIZE (h);
+ EMACS_INT i, size = HASH_TABLE_SIZE (h);
for (i = 0; i < size; ++i)
{
static int
sweep_weak_table (struct Lisp_Hash_Table *h, int remove_entries_p)
{
- int bucket, n, marked;
+ EMACS_INT bucket, n;
+ int marked;
n = ASIZE (h->index) & ~ARRAY_MARK_FLAG;
marked = 0;
prev = Qnil;
for (idx = HASH_INDEX (h, bucket); !NILP (idx); idx = next)
{
- int i = XFASTINT (idx);
+ EMACS_INT i = XFASTINT (idx);
int key_known_to_survive_p = survives_gc_p (HASH_KEY (h, i));
int value_known_to_survive_p = survives_gc_p (HASH_VALUE (h, i));
int remove_p;
#define SXHASH_MAX_LEN 7
-/* Combine two integers X and Y for hashing. */
+/* Combine two integers X and Y for hashing. The result might not fit
+ into a Lisp integer. */
#define SXHASH_COMBINE(X, Y) \
- ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
- + (unsigned)(Y))
+ ((((EMACS_UINT) (X) << 4) + ((EMACS_UINT) (X) >> (BITS_PER_EMACS_INT - 4))) \
+ + (EMACS_UINT) (Y))
+/* Hash X, returning a value that fits into a Lisp integer. */
+#define SXHASH_REDUCE(X) \
+ ((((X) ^ (X) >> (BITS_PER_EMACS_INT - FIXNUM_BITS))) & INTMASK)
/* Return a hash for string PTR which has length LEN. The hash
code returned is guaranteed to fit in a Lisp integer. */
-static unsigned
-sxhash_string (unsigned char *ptr, int len)
+static EMACS_UINT
+sxhash_string (unsigned char *ptr, EMACS_INT len)
{
unsigned char *p = ptr;
unsigned char *end = p + len;
unsigned char c;
- unsigned hash = 0;
+ EMACS_UINT hash = 0;
while (p != end)
{
c = *p++;
if (c >= 0140)
c -= 40;
- hash = ((hash << 4) + (hash >> 28) + c);
+ hash = SXHASH_COMBINE (hash, c);
}
- return hash & INTMASK;
+ return SXHASH_REDUCE (hash);
}
+/* Return a hash for the floating point value VAL. */
+
+static EMACS_INT
+sxhash_float (double val)
+{
+ EMACS_UINT hash = 0;
+ enum {
+ WORDS_PER_DOUBLE = (sizeof val / sizeof hash
+ + (sizeof val % sizeof hash != 0))
+ };
+ union {
+ double val;
+ EMACS_UINT word[WORDS_PER_DOUBLE];
+ } u;
+ int i;
+ u.val = val;
+ memset (&u.val + 1, 0, sizeof u - sizeof u.val);
+ for (i = 0; i < WORDS_PER_DOUBLE; i++)
+ hash = SXHASH_COMBINE (hash, u.word[i]);
+ return SXHASH_REDUCE (hash);
+}
/* Return a hash for list LIST. DEPTH is the current depth in the
list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
-static unsigned
+static EMACS_UINT
sxhash_list (Lisp_Object list, int depth)
{
- unsigned hash = 0;
+ EMACS_UINT hash = 0;
int i;
if (depth < SXHASH_MAX_DEPTH)
CONSP (list) && i < SXHASH_MAX_LEN;
list = XCDR (list), ++i)
{
- unsigned hash2 = sxhash (XCAR (list), depth + 1);
+ EMACS_UINT hash2 = sxhash (XCAR (list), depth + 1);
hash = SXHASH_COMBINE (hash, hash2);
}
if (!NILP (list))
{
- unsigned hash2 = sxhash (list, depth + 1);
+ EMACS_UINT hash2 = sxhash (list, depth + 1);
hash = SXHASH_COMBINE (hash, hash2);
}
- return hash;
+ return SXHASH_REDUCE (hash);
}
/* Return a hash for vector VECTOR. DEPTH is the current depth in
the Lisp structure. */
-static unsigned
+static EMACS_UINT
sxhash_vector (Lisp_Object vec, int depth)
{
- unsigned hash = ASIZE (vec);
+ EMACS_UINT hash = ASIZE (vec);
int i, n;
n = min (SXHASH_MAX_LEN, ASIZE (vec));
for (i = 0; i < n; ++i)
{
- unsigned hash2 = sxhash (AREF (vec, i), depth + 1);
+ EMACS_UINT hash2 = sxhash (AREF (vec, i), depth + 1);
hash = SXHASH_COMBINE (hash, hash2);
}
- return hash;
+ return SXHASH_REDUCE (hash);
}
-
/* Return a hash for bool-vector VECTOR. */
-static unsigned
+static EMACS_UINT
sxhash_bool_vector (Lisp_Object vec)
{
- unsigned hash = XBOOL_VECTOR (vec)->size;
+ EMACS_UINT hash = XBOOL_VECTOR (vec)->size;
int i, n;
n = min (SXHASH_MAX_LEN, XBOOL_VECTOR (vec)->header.size);
for (i = 0; i < n; ++i)
hash = SXHASH_COMBINE (hash, XBOOL_VECTOR (vec)->data[i]);
- return hash;
+ return SXHASH_REDUCE (hash);
}
/* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
structure. Value is an unsigned integer clipped to INTMASK. */
-unsigned
+EMACS_UINT
sxhash (Lisp_Object obj, int depth)
{
- unsigned hash;
+ EMACS_UINT hash;
if (depth > SXHASH_MAX_DEPTH)
return 0;
break;
case Lisp_Float:
- {
- double val = XFLOAT_DATA (obj);
- unsigned char *p = (unsigned char *) &val;
- size_t i;
- for (hash = 0, i = 0; i < sizeof val; i++)
- hash = SXHASH_COMBINE (hash, p[i]);
- break;
- }
+ hash = sxhash_float (XFLOAT_DATA (obj));
+ break;
default:
abort ();
}
- return hash & INTMASK;
+ return hash;
}
doc: /* Compute a hash code for OBJ and return it as integer. */)
(Lisp_Object obj)
{
- unsigned hash = sxhash (obj, 0);
+ EMACS_UINT hash = sxhash (obj, 0);
return make_number (hash);
}
is nil.
usage: (make-hash-table &rest KEYWORD-ARGS) */)
- (size_t nargs, Lisp_Object *args)
+ (ptrdiff_t nargs, Lisp_Object *args)
{
Lisp_Object test, size, rehash_size, rehash_threshold, weak;
Lisp_Object user_test, user_hash;
char *used;
- size_t i;
+ ptrdiff_t i;
/* The vector `used' is used to keep track of arguments that
have been consumed. */
/* Look for `:rehash-size SIZE'. */
i = get_key_arg (QCrehash_size, nargs, args, used);
rehash_size = i ? args[i] : make_float (DEFAULT_REHASH_SIZE);
- if (!NUMBERP (rehash_size)
- || (INTEGERP (rehash_size) && XINT (rehash_size) <= 0)
- || XFLOATINT (rehash_size) <= 1.0)
+ if (! ((INTEGERP (rehash_size) && 0 < XINT (rehash_size))
+ || (FLOATP (rehash_size) && 1 < XFLOAT_DATA (rehash_size))))
signal_error ("Invalid hash table rehash size", rehash_size);
/* Look for `:rehash-threshold THRESHOLD'. */
i = get_key_arg (QCrehash_threshold, nargs, args, used);
rehash_threshold = i ? args[i] : make_float (DEFAULT_REHASH_THRESHOLD);
- if (!FLOATP (rehash_threshold)
- || XFLOATINT (rehash_threshold) <= 0.0
- || XFLOATINT (rehash_threshold) > 1.0)
+ if (! (FLOATP (rehash_threshold)
+ && 0 < XFLOAT_DATA (rehash_threshold)
+ && XFLOAT_DATA (rehash_threshold) <= 1))
signal_error ("Invalid hash table rehash threshold", rehash_threshold);
/* Look for `:weakness WEAK'. */
(Lisp_Object key, Lisp_Object table, Lisp_Object dflt)
{
struct Lisp_Hash_Table *h = check_hash_table (table);
- int i = hash_lookup (h, key, NULL);
+ EMACS_INT i = hash_lookup (h, key, NULL);
return i >= 0 ? HASH_VALUE (h, i) : dflt;
}
DEFUN ("puthash", Fputhash, Sputhash, 3, 3, 0,
doc: /* Associate KEY with VALUE in hash table TABLE.
If KEY is already present in table, replace its current value with
-VALUE. */)
+VALUE. In any case, return VALUE. */)
(Lisp_Object key, Lisp_Object value, Lisp_Object table)
{
struct Lisp_Hash_Table *h = check_hash_table (table);
- int i;
- unsigned hash;
+ EMACS_INT i;
+ EMACS_UINT hash;
i = hash_lookup (h, key, &hash);
if (i >= 0)
{
struct Lisp_Hash_Table *h = check_hash_table (table);
Lisp_Object args[3];
- int i;
+ EMACS_INT i;
for (i = 0; i < HASH_TABLE_SIZE (h); ++i)
if (!NILP (HASH_HASH (h, i)))
\f
/************************************************************************
- MD5 and SHA1
+ MD5, SHA-1, and SHA-2
************************************************************************/
#include "md5.h"
#include "sha1.h"
+#include "sha256.h"
+#include "sha512.h"
-/* TYPE: 0 for md5, 1 for sha1. */
+/* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
static Lisp_Object
-crypto_hash_function (int type, Lisp_Object object, Lisp_Object start, Lisp_Object end, Lisp_Object coding_system, Lisp_Object noerror, Lisp_Object binary)
+secure_hash (Lisp_Object algorithm, Lisp_Object object, Lisp_Object start, Lisp_Object end, Lisp_Object coding_system, Lisp_Object noerror, Lisp_Object binary)
{
int i;
EMACS_INT size;
register EMACS_INT b, e;
register struct buffer *bp;
EMACS_INT temp;
- Lisp_Object res=Qnil;
+ int digest_size;
+ void *(*hash_func) (const char *, size_t, void *);
+ Lisp_Object digest;
+
+ CHECK_SYMBOL (algorithm);
if (STRINGP (object))
{
object = code_convert_string (object, coding_system, Qnil, 1, 0, 0);
}
- switch (type)
+ if (EQ (algorithm, Qmd5))
{
- case 0: /* MD5 */
- {
- char digest[16];
- md5_buffer (SSDATA (object) + start_byte,
- SBYTES (object) - (size_byte - end_byte),
- digest);
+ digest_size = MD5_DIGEST_SIZE;
+ hash_func = md5_buffer;
+ }
+ else if (EQ (algorithm, Qsha1))
+ {
+ digest_size = SHA1_DIGEST_SIZE;
+ hash_func = sha1_buffer;
+ }
+ else if (EQ (algorithm, Qsha224))
+ {
+ digest_size = SHA224_DIGEST_SIZE;
+ hash_func = sha224_buffer;
+ }
+ else if (EQ (algorithm, Qsha256))
+ {
+ digest_size = SHA256_DIGEST_SIZE;
+ hash_func = sha256_buffer;
+ }
+ else if (EQ (algorithm, Qsha384))
+ {
+ digest_size = SHA384_DIGEST_SIZE;
+ hash_func = sha384_buffer;
+ }
+ else if (EQ (algorithm, Qsha512))
+ {
+ digest_size = SHA512_DIGEST_SIZE;
+ hash_func = sha512_buffer;
+ }
+ else
+ error ("Invalid algorithm arg: %s", SDATA (Fsymbol_name (algorithm)));
- if (NILP (binary))
- {
- char value[33];
- for (i = 0; i < 16; i++)
- sprintf (&value[2 * i], "%02x", digest[i]);
- res = make_string (value, 32);
- }
- else
- res = make_string (digest, 16);
- break;
- }
+ /* allocate 2 x digest_size so that it can be re-used to hold the
+ hexified value */
+ digest = make_uninit_string (digest_size * 2);
- case 1: /* SHA1 */
- {
- char digest[20];
- sha1_buffer (SSDATA (object) + start_byte,
- SBYTES (object) - (size_byte - end_byte),
- digest);
- if (NILP (binary))
- {
- char value[41];
- for (i = 0; i < 20; i++)
- sprintf (&value[2 * i], "%02x", digest[i]);
- res = make_string (value, 40);
- }
- else
- res = make_string (digest, 20);
- break;
- }
- }
+ hash_func (SSDATA (object) + start_byte,
+ SBYTES (object) - (size_byte - end_byte),
+ SSDATA (digest));
- return res;
+ if (NILP (binary))
+ {
+ unsigned char *p = SDATA (digest);
+ for (i = digest_size - 1; i >= 0; i--)
+ {
+ static char const hexdigit[16] = "0123456789abcdef";
+ int p_i = p[i];
+ p[2 * i] = hexdigit[p_i >> 4];
+ p[2 * i + 1] = hexdigit[p_i & 0xf];
+ }
+ return digest;
+ }
+ else
+ return make_unibyte_string (SSDATA (digest), digest_size);
}
DEFUN ("md5", Fmd5, Smd5, 1, 5, 0,
guesswork fails. Normally, an error is signaled in such case. */)
(Lisp_Object object, Lisp_Object start, Lisp_Object end, Lisp_Object coding_system, Lisp_Object noerror)
{
- return crypto_hash_function (0, object, start, end, coding_system, noerror, Qnil);
+ return secure_hash (Qmd5, object, start, end, coding_system, noerror, Qnil);
}
-DEFUN ("sha1", Fsha1, Ssha1, 1, 4, 0,
- doc: /* Return the SHA-1 (Secure Hash Algorithm) of an OBJECT.
-
-OBJECT is either a string or a buffer. Optional arguments START and
-END are character positions specifying which portion of OBJECT for
-computing the hash. If BINARY is non-nil, return a string in binary
-form. */)
- (Lisp_Object object, Lisp_Object start, Lisp_Object end, Lisp_Object binary)
+DEFUN ("secure-hash", Fsecure_hash, Ssecure_hash, 2, 5, 0,
+ doc: /* Return the secure hash of an OBJECT.
+ALGORITHM is a symbol: md5, sha1, sha224, sha256, sha384 or sha512.
+OBJECT is either a string or a buffer.
+Optional arguments START and END are character positions specifying
+which portion of OBJECT for computing the hash. If BINARY is non-nil,
+return a string in binary form. */)
+ (Lisp_Object algorithm, Lisp_Object object, Lisp_Object start, Lisp_Object end, Lisp_Object binary)
{
- return crypto_hash_function (1, object, start, end, Qnil, Qnil, binary);
+ return secure_hash (algorithm, object, start, end, Qnil, Qnil, binary);
}
-
\f
void
syms_of_fns (void)
{
+ DEFSYM (Qmd5, "md5");
+ DEFSYM (Qsha1, "sha1");
+ DEFSYM (Qsha224, "sha224");
+ DEFSYM (Qsha256, "sha256");
+ DEFSYM (Qsha384, "sha384");
+ DEFSYM (Qsha512, "sha512");
+
/* Hash table stuff. */
- Qhash_table_p = intern_c_string ("hash-table-p");
- staticpro (&Qhash_table_p);
- Qeq = intern_c_string ("eq");
- staticpro (&Qeq);
- Qeql = intern_c_string ("eql");
- staticpro (&Qeql);
- Qequal = intern_c_string ("equal");
- staticpro (&Qequal);
- QCtest = intern_c_string (":test");
- staticpro (&QCtest);
- QCsize = intern_c_string (":size");
- staticpro (&QCsize);
- QCrehash_size = intern_c_string (":rehash-size");
- staticpro (&QCrehash_size);
- QCrehash_threshold = intern_c_string (":rehash-threshold");
- staticpro (&QCrehash_threshold);
- QCweakness = intern_c_string (":weakness");
- staticpro (&QCweakness);
- Qkey = intern_c_string ("key");
- staticpro (&Qkey);
- Qvalue = intern_c_string ("value");
- staticpro (&Qvalue);
- Qhash_table_test = intern_c_string ("hash-table-test");
- staticpro (&Qhash_table_test);
- Qkey_or_value = intern_c_string ("key-or-value");
- staticpro (&Qkey_or_value);
- Qkey_and_value = intern_c_string ("key-and-value");
- staticpro (&Qkey_and_value);
+ DEFSYM (Qhash_table_p, "hash-table-p");
+ DEFSYM (Qeq, "eq");
+ DEFSYM (Qeql, "eql");
+ DEFSYM (Qequal, "equal");
+ DEFSYM (QCtest, ":test");
+ DEFSYM (QCsize, ":size");
+ DEFSYM (QCrehash_size, ":rehash-size");
+ DEFSYM (QCrehash_threshold, ":rehash-threshold");
+ DEFSYM (QCweakness, ":weakness");
+ DEFSYM (Qkey, "key");
+ DEFSYM (Qvalue, "value");
+ DEFSYM (Qhash_table_test, "hash-table-test");
+ DEFSYM (Qkey_or_value, "key-or-value");
+ DEFSYM (Qkey_and_value, "key-and-value");
defsubr (&Ssxhash);
defsubr (&Smake_hash_table);
defsubr (&Smaphash);
defsubr (&Sdefine_hash_table_test);
- Qstring_lessp = intern_c_string ("string-lessp");
- staticpro (&Qstring_lessp);
- Qprovide = intern_c_string ("provide");
- staticpro (&Qprovide);
- Qrequire = intern_c_string ("require");
- staticpro (&Qrequire);
- Qyes_or_no_p_history = intern_c_string ("yes-or-no-p-history");
- staticpro (&Qyes_or_no_p_history);
- Qcursor_in_echo_area = intern_c_string ("cursor-in-echo-area");
- staticpro (&Qcursor_in_echo_area);
- Qwidget_type = intern_c_string ("widget-type");
- staticpro (&Qwidget_type);
+ DEFSYM (Qstring_lessp, "string-lessp");
+ DEFSYM (Qprovide, "provide");
+ DEFSYM (Qrequire, "require");
+ DEFSYM (Qyes_or_no_p_history, "yes-or-no-p-history");
+ DEFSYM (Qcursor_in_echo_area, "cursor-in-echo-area");
+ DEFSYM (Qwidget_type, "widget-type");
staticpro (&string_char_byte_cache_string);
string_char_byte_cache_string = Qnil;
doc: /* A list of symbols which are the features of the executing Emacs.
Used by `featurep' and `require', and altered by `provide'. */);
Vfeatures = Fcons (intern_c_string ("emacs"), Qnil);
- Qsubfeatures = intern_c_string ("subfeatures");
- staticpro (&Qsubfeatures);
+ DEFSYM (Qsubfeatures, "subfeatures");
#ifdef HAVE_LANGINFO_CODESET
- Qcodeset = intern_c_string ("codeset");
- staticpro (&Qcodeset);
- Qdays = intern_c_string ("days");
- staticpro (&Qdays);
- Qmonths = intern_c_string ("months");
- staticpro (&Qmonths);
- Qpaper = intern_c_string ("paper");
- staticpro (&Qpaper);
+ DEFSYM (Qcodeset, "codeset");
+ DEFSYM (Qdays, "days");
+ DEFSYM (Qmonths, "months");
+ DEFSYM (Qpaper, "paper");
#endif /* HAVE_LANGINFO_CODESET */
DEFVAR_BOOL ("use-dialog-box", use_dialog_box,
defsubr (&Sbase64_encode_string);
defsubr (&Sbase64_decode_string);
defsubr (&Smd5);
- defsubr (&Ssha1);
+ defsubr (&Ssecure_hash);
defsubr (&Slocale_info);
}
HCoop / bpt / emacs.git / blobdiff