#include <config.h>
#include <unistd.h>
+#include <filevercmp.h>
#include <intprops.h>
#include <vla.h>
+#include <errno.h>
#include "lisp.h"
#include "character.h"
#include "intervals.h"
#include "window.h"
- #if __GNUC__ >= 4
static void sort_vector_copy (Lisp_Object, ptrdiff_t,
- Lisp_Object [restrict], Lisp_Object [restrict]);
- #else
- static void sort_vector_copy (Lisp_Object, ptrdiff_t,
- Lisp_Object [], Lisp_Object []);
- #endif
+ Lisp_Object *restrict, Lisp_Object *restrict);
static bool internal_equal (Lisp_Object, Lisp_Object, int, bool, Lisp_Object);
DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
return i1 < SCHARS (string2) ? Qt : Qnil;
}
+DEFUN ("string-version-lessp", Fstring_version_lessp,
+ Sstring_version_lessp, 2, 2, 0,
+ doc: /* Return non-nil if S1 is less than S2, as version strings.
+
+This function compares version strings S1 and S2:
+ 1) By prefix lexicographically.
+ 2) Then by version (similarly to version comparison of Debian's dpkg).
+ Leading zeros in version numbers are ignored.
+ 3) If both prefix and version are equal, compare as ordinary strings.
+
+For example, \"foo2.png\" compares less than \"foo12.png\".
+Case is significant.
+Symbols are also allowed; their print names are used instead. */)
+ (Lisp_Object string1, Lisp_Object string2)
+{
+ if (SYMBOLP (string1))
+ string1 = SYMBOL_NAME (string1);
+ if (SYMBOLP (string2))
+ string2 = SYMBOL_NAME (string2);
+ CHECK_STRING (string1);
+ CHECK_STRING (string2);
+
+ char *p1 = SSDATA (string1);
+ char *p2 = SSDATA (string2);
+ char *lim1 = p1 + SBYTES (string1);
+ char *lim2 = p2 + SBYTES (string2);
+ int cmp;
+
+ while ((cmp = filevercmp (p1, p2)) == 0)
+ {
+ /* If the strings are identical through their first null bytes,
+ skip past identical prefixes and try again. */
+ ptrdiff_t size = strlen (p1) + 1;
+ p1 += size;
+ p2 += size;
+ if (lim1 < p1)
+ return lim2 < p2 ? Qnil : Qt;
+ if (lim2 < p2)
+ return Qnil;
+ }
+
+ return cmp < 0 ? Qt : Qnil;
+}
+
DEFUN ("string-collate-lessp", Fstring_collate_lessp, Sstring_collate_lessp, 2, 4, 0,
doc: /* Return t if first arg string is less than second in collation order.
Symbols are also allowed; their print names are used instead.
(register Lisp_Object elt, Lisp_Object list)
{
register Lisp_Object tail;
- for (tail = list; CONSP (tail); tail = XCDR (tail))
+ for (tail = list; !NILP (tail); tail = XCDR (tail))
{
register Lisp_Object tem;
CHECK_LIST_CONS (tail, list);
if (!FLOATP (elt))
return Fmemq (elt, list);
- for (tail = list; CONSP (tail); tail = XCDR (tail))
+ for (tail = list; !NILP (tail); tail = XCDR (tail))
{
register Lisp_Object tem;
CHECK_LIST_CONS (tail, list);
{
Lisp_Object tail, prev;
- for (tail = seq, prev = Qnil; CONSP (tail); tail = XCDR (tail))
+ for (tail = seq, prev = Qnil; !NILP (tail); tail = XCDR (tail))
{
CHECK_LIST_CONS (tail, seq);
DEFUN ("require", Frequire, Srequire, 1, 3, 0,
doc: /* If feature FEATURE is not loaded, load it from FILENAME.
-If FEATURE is not a member of the list `features', then the feature
-is not loaded; so load the file FILENAME.
-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',
-`.el', or the system-dependent suffix for dynamic module files, in that
-order. The name without appended suffix will not be used.
-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.
-The normal messages at start and end of loading FILENAME are suppressed. */)
+If FEATURE is not a member of the list `features', then the feature is
+not loaded; so load the file FILENAME.
+
+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', `.el', or the system-dependent suffix for dynamic module
+files, in that order. The name without appended suffix will not be
+used. See `get-load-suffixes' for the complete list of suffixes.
+
+The directories in `load-path' are searched when trying to find the
+file name.
+
+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.
+
+The normal messages at start and end of loading FILENAME are
+suppressed. */)
(Lisp_Object feature, Lisp_Object filename, Lisp_Object noerror)
{
Lisp_Object tem;
{
char *str = NULL;
#ifdef HAVE_LANGINFO_CODESET
- Lisp_Object val;
if (EQ (item, Qcodeset))
{
str = nl_langinfo (CODESET);
for (i = 0; i < 7; i++)
{
str = nl_langinfo (days[i]);
- val = build_unibyte_string (str);
+ AUTO_STRING (val, str);
/* Fixme: Is this coding system necessarily right, even if
it is consistent with CODESET? If not, what to do? */
ASET (v, i, code_convert_string_norecord (val, Vlocale_coding_system,
for (i = 0; i < 12; i++)
{
str = nl_langinfo (months[i]);
- val = build_unibyte_string (str);
+ AUTO_STRING (val, str);
ASET (v, i, code_convert_string_norecord (val, Vlocale_coding_system,
0));
}
Low-level Functions
***********************************************************************/
-struct hash_table_test hashtest_eq, hashtest_eql, hashtest_equal;
-
/* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
HASH2 in hash table H using `eql'. Value is true if KEY1 and
KEY2 are the same. */
return !NILP (call2 (ht->user_cmp_function, key1, key2));
}
-
/* Value is a hash code for KEY for use in hash table H which uses
`eq' to compare keys. The hash code returned is guaranteed to fit
in a Lisp integer. */
static EMACS_UINT
hashfn_eq (struct hash_table_test *ht, Lisp_Object key)
{
- EMACS_UINT hash = XHASH (key) ^ XTYPE (key);
- return hash;
+ return XHASH (key) ^ XTYPE (key);
}
/* Value is a hash code for KEY for use in hash table H which uses
- `eql' to compare keys. The hash code returned is guaranteed to fit
+ `equal' to compare keys. The hash code returned is guaranteed to fit
in a Lisp integer. */
static EMACS_UINT
-hashfn_eql (struct hash_table_test *ht, Lisp_Object key)
+hashfn_equal (struct hash_table_test *ht, Lisp_Object key)
{
- EMACS_UINT hash;
- if (FLOATP (key))
- hash = sxhash (key, 0);
- else
- hash = XHASH (key) ^ XTYPE (key);
- return hash;
+ return sxhash (key, 0);
}
/* Value is a hash code for KEY for use in hash table H which uses
- `equal' to compare keys. The hash code returned is guaranteed to fit
+ `eql' to compare keys. The hash code returned is guaranteed to fit
in a Lisp integer. */
static EMACS_UINT
-hashfn_equal (struct hash_table_test *ht, Lisp_Object key)
+hashfn_eql (struct hash_table_test *ht, Lisp_Object key)
{
- EMACS_UINT hash = sxhash (key, 0);
- return hash;
+ return FLOATP (key) ? hashfn_equal (ht, key) : hashfn_eq (ht, key);
}
/* Value is a hash code for KEY for use in hash table H which uses as
return hashfn_eq (ht, hash);
}
+struct hash_table_test const
+ hashtest_eq = { LISPSYM_INITIALLY (Qeq), LISPSYM_INITIALLY (Qnil),
+ LISPSYM_INITIALLY (Qnil), 0, hashfn_eq },
+ hashtest_eql = { LISPSYM_INITIALLY (Qeql), LISPSYM_INITIALLY (Qnil),
+ LISPSYM_INITIALLY (Qnil), cmpfn_eql, hashfn_eql },
+ hashtest_equal = { LISPSYM_INITIALLY (Qequal), LISPSYM_INITIALLY (Qnil),
+ LISPSYM_INITIALLY (Qnil), cmpfn_equal, hashfn_equal };
+
/* Allocate basically initialized hash table. */
static struct Lisp_Hash_Table *
Lisp Interface
***********************************************************************/
+DEFUN ("sxhash-eq", Fsxhash_eq, Ssxhash_eq, 1, 1, 0,
+ doc: /* Return an integer hash code for OBJ suitable for `eq'.
+If (eq A B), then (= (sxhash-eq A) (sxhash-eq B)). */)
+ (Lisp_Object obj)
+{
+ return make_number (hashfn_eq (NULL, obj));
+}
-DEFUN ("sxhash", Fsxhash, Ssxhash, 1, 1, 0,
- doc: /* Compute a hash code for OBJ and return it as integer. */)
+DEFUN ("sxhash-eql", Fsxhash_eql, Ssxhash_eql, 1, 1, 0,
+ doc: /* Return an integer hash code for OBJ suitable for `eql'.
+If (eql A B), then (= (sxhash-eql A) (sxhash-eql B)). */)
(Lisp_Object obj)
{
- EMACS_UINT hash = sxhash (obj, 0);
- return make_number (hash);
+ return make_number (hashfn_eql (NULL, obj));
}
+DEFUN ("sxhash-equal", Fsxhash_equal, Ssxhash_equal, 1, 1, 0,
+ doc: /* Return an integer hash code for OBJ suitable for `equal'.
+If (equal A B), then (= (sxhash-equal A) (sxhash-equal B)). */)
+ (Lisp_Object obj)
+{
+ return make_number (hashfn_equal (NULL, obj));
+}
DEFUN ("make-hash-table", Fmake_hash_table, Smake_hash_table, 0, MANY, 0,
doc: /* Create and return a new hash table.
#include "sha256.h"
#include "sha512.h"
+static Lisp_Object
+make_digest_string (Lisp_Object digest, int digest_size)
+{
+ unsigned char *p = SDATA (digest);
+
+ for (int 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;
+}
+
/* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
static Lisp_Object
Lisp_Object end, Lisp_Object coding_system, Lisp_Object noerror,
Lisp_Object binary)
{
- int i;
ptrdiff_t size, start_char = 0, start_byte, end_char = 0, end_byte;
register EMACS_INT b, e;
register struct buffer *bp;
SSDATA (digest));
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;
- }
+ return make_digest_string (digest, digest_size);
else
return make_unibyte_string (SSDATA (digest), digest_size);
}
{
return secure_hash (algorithm, object, start, end, Qnil, Qnil, binary);
}
+
+DEFUN ("buffer-hash", Fbuffer_hash, Sbuffer_hash, 0, 1, 0,
+ doc: /* Return a hash of the contents of BUFFER-OR-NAME.
+This hash is performed on the raw internal format of the buffer,
+disregarding any coding systems.
+If nil, use the current buffer." */ )
+ (Lisp_Object buffer_or_name)
+{
+ Lisp_Object buffer;
+ struct buffer *b;
+ struct sha1_ctx ctx;
+
+ if (NILP (buffer_or_name))
+ buffer = Fcurrent_buffer ();
+ else
+ buffer = Fget_buffer (buffer_or_name);
+ if (NILP (buffer))
+ nsberror (buffer_or_name);
+
+ b = XBUFFER (buffer);
+ sha1_init_ctx (&ctx);
+
+ /* Process the first part of the buffer. */
+ sha1_process_bytes (BUF_BEG_ADDR (b),
+ BUF_GPT_BYTE (b) - BUF_BEG_BYTE (b),
+ &ctx);
+
+ /* If the gap is before the end of the buffer, process the last half
+ of the buffer. */
+ if (BUF_GPT_BYTE (b) < BUF_Z_BYTE (b))
+ sha1_process_bytes (BUF_GAP_END_ADDR (b),
+ BUF_Z_ADDR (b) - BUF_GAP_END_ADDR (b),
+ &ctx);
+
+ Lisp_Object digest = make_uninit_string (SHA1_DIGEST_SIZE * 2);
+ sha1_finish_ctx (&ctx, SSDATA (digest));
+ return make_digest_string (digest, SHA1_DIGEST_SIZE);
+}
+
\f
void
syms_of_fns (void)
DEFSYM (Qkey_or_value, "key-or-value");
DEFSYM (Qkey_and_value, "key-and-value");
- defsubr (&Ssxhash);
+ defsubr (&Ssxhash_eq);
+ defsubr (&Ssxhash_eql);
+ defsubr (&Ssxhash_equal);
defsubr (&Smake_hash_table);
defsubr (&Scopy_hash_table);
defsubr (&Shash_table_count);
defsubr (&Sstring_equal);
defsubr (&Scompare_strings);
defsubr (&Sstring_lessp);
+ defsubr (&Sstring_version_lessp);
defsubr (&Sstring_collate_lessp);
defsubr (&Sstring_collate_equalp);
defsubr (&Sappend);
defsubr (&Sbase64_decode_string);
defsubr (&Smd5);
defsubr (&Ssecure_hash);
+ defsubr (&Sbuffer_hash);
defsubr (&Slocale_info);
-
- hashtest_eq.name = Qeq;
- hashtest_eq.user_hash_function = Qnil;
- hashtest_eq.user_cmp_function = Qnil;
- hashtest_eq.cmpfn = 0;
- hashtest_eq.hashfn = hashfn_eq;
-
- hashtest_eql.name = Qeql;
- hashtest_eql.user_hash_function = Qnil;
- hashtest_eql.user_cmp_function = Qnil;
- hashtest_eql.cmpfn = cmpfn_eql;
- hashtest_eql.hashfn = hashfn_eql;
-
- hashtest_equal.name = Qequal;
- hashtest_equal.user_hash_function = Qnil;
- hashtest_equal.user_cmp_function = Qnil;
- hashtest_equal.cmpfn = cmpfn_equal;
- hashtest_equal.hashfn = hashfn_equal;
}