static Lisp_Object Qmd5, Qsha1, Qsha224, Qsha256, Qsha384, Qsha512;
static bool internal_equal (Lisp_Object, Lisp_Object, int, bool, Lisp_Object);
-\f
+
DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
doc: /* Return the argument unchanged. */)
(Lisp_Object arg)
\(exclusive). If START1 is nil, it defaults to 0, the beginning of
the string; if END1 is nil, it defaults to the length of the string.
Likewise, in string STR2, compare the part between START2 and END2.
+Like in `substring', negative values are counted from the end.
The strings are compared by the numeric values of their characters.
For instance, STR1 is "less than" STR2 if its first differing
- 1 - N is the number of characters that match at the beginning.
If string STR1 is greater, the value is a positive number N;
N - 1 is the number of characters that match at the beginning. */)
- (Lisp_Object str1, Lisp_Object start1, Lisp_Object end1, Lisp_Object str2, Lisp_Object start2, Lisp_Object end2, Lisp_Object ignore_case)
+ (Lisp_Object str1, Lisp_Object start1, Lisp_Object end1, Lisp_Object str2,
+ Lisp_Object start2, Lisp_Object end2, Lisp_Object ignore_case)
{
- register ptrdiff_t end1_char, end2_char;
- register ptrdiff_t i1, i1_byte, i2, i2_byte;
+ ptrdiff_t from1, to1, from2, to2, i1, i1_byte, i2, i2_byte;
CHECK_STRING (str1);
CHECK_STRING (str2);
- if (NILP (start1))
- start1 = make_number (0);
- if (NILP (start2))
- start2 = make_number (0);
- CHECK_NATNUM (start1);
- CHECK_NATNUM (start2);
- if (! NILP (end1))
- CHECK_NATNUM (end1);
- if (! NILP (end2))
- CHECK_NATNUM (end2);
-
- end1_char = SCHARS (str1);
- if (! NILP (end1) && end1_char > XINT (end1))
- end1_char = XINT (end1);
- if (end1_char < XINT (start1))
- args_out_of_range (str1, start1);
-
- end2_char = SCHARS (str2);
- if (! NILP (end2) && end2_char > XINT (end2))
- end2_char = XINT (end2);
- if (end2_char < XINT (start2))
- args_out_of_range (str2, start2);
-
- i1 = XINT (start1);
- i2 = XINT (start2);
+
+ validate_subarray (str1, start1, end1, SCHARS (str1), &from1, &to1);
+ validate_subarray (str2, start2, end2, SCHARS (str2), &from2, &to2);
+
+ i1 = from1;
+ i2 = from2;
i1_byte = string_char_to_byte (str1, i1);
i2_byte = string_char_to_byte (str2, i2);
- while (i1 < end1_char && i2 < end2_char)
+ while (i1 < to1 && i2 < to2)
{
/* When we find a mismatch, we must compare the
characters, not just the bytes. */
int c1, c2;
- if (STRING_MULTIBYTE (str1))
- FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1, str1, i1, i1_byte);
- else
- {
- c1 = SREF (str1, i1++);
- MAKE_CHAR_MULTIBYTE (c1);
- }
-
- if (STRING_MULTIBYTE (str2))
- FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2, str2, i2, i2_byte);
- else
- {
- c2 = SREF (str2, i2++);
- MAKE_CHAR_MULTIBYTE (c2);
- }
+ FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c1, str1, i1, i1_byte);
+ FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c2, str2, i2, i2_byte);
if (c1 == c2)
continue;
if (! NILP (ignore_case))
{
- Lisp_Object tem;
-
- tem = Fupcase (make_number (c1));
- c1 = XINT (tem);
- tem = Fupcase (make_number (c2));
- c2 = XINT (tem);
+ c1 = XINT (Fupcase (make_number (c1)));
+ c2 = XINT (Fupcase (make_number (c2)));
}
if (c1 == c2)
past the character that we are comparing;
hence we don't add or subtract 1 here. */
if (c1 < c2)
- return make_number (- i1 + XINT (start1));
+ return make_number (- i1 + from1);
else
- return make_number (i1 - XINT (start1));
+ return make_number (i1 - from1);
}
- if (i1 < end1_char)
- return make_number (i1 - XINT (start1) + 1);
- if (i2 < end2_char)
- return make_number (- i1 + XINT (start1) - 1);
+ if (i1 < to1)
+ return make_number (i1 - from1 + 1);
+ if (i2 < to2)
+ return make_number (- i1 + from1 - 1);
return Qt;
}
if (STRING_MULTIBYTE (string))
{
ptrdiff_t chars = SCHARS (string);
- unsigned char *str = xmalloc (chars);
+ unsigned char *str = xmalloc_atomic (chars);
ptrdiff_t converted = str_to_unibyte (SDATA (string), str, chars);
if (converted < chars)
Count negative values backwards from the end.
Set *IFROM and *ITO to the two indexes used. */
-static void
+void
validate_subarray (Lisp_Object array, Lisp_Object from, Lisp_Object to,
- ptrdiff_t size, EMACS_INT *ifrom, EMACS_INT *ito)
+ ptrdiff_t size, ptrdiff_t *ifrom, ptrdiff_t *ito)
{
EMACS_INT f, t;
(Lisp_Object string, Lisp_Object from, Lisp_Object to)
{
Lisp_Object res;
- ptrdiff_t size;
- EMACS_INT ifrom, ito;
+ ptrdiff_t size, ifrom, ito;
if (STRINGP (string))
size = SCHARS (string);
With one argument, just copy STRING without its properties. */)
(Lisp_Object string, register Lisp_Object from, Lisp_Object to)
{
- ptrdiff_t size;
- EMACS_INT from_char, to_char;
- ptrdiff_t from_byte, to_byte;
+ ptrdiff_t from_char, to_char, from_byte, to_byte, size;
CHECK_STRING (string);
Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
(Lisp_Object obj1, Lisp_Object obj2)
{
- if (FLOATP (obj1))
- return internal_equal (obj1, obj2, 0, 0, Qnil) ? Qt : Qnil;
- else
- return EQ (obj1, obj2) ? Qt : Qnil;
+ return scm_is_true (scm_eqv_p (obj1, obj2)) ? Qt : Qnil;
}
DEFUN ("equal", Fequal, Sequal, 2, 2, 0,
key_and_value vector of the hash table. This could be done
if a `:linear-search t' argument is given to make-hash-table. */
-
-/* The list of all weak hash tables. Don't staticpro this one. */
-
-static struct Lisp_Hash_Table *weak_hash_tables;
-
/* Various symbols. */
static Lisp_Object Qhash_table_p;
eassert (HASH_TABLE_P (table));
eassert (XHASH_TABLE (table) == h);
- /* Maybe add this hash table to the list of all weak hash tables. */
- if (NILP (h->weak))
- h->next_weak = NULL;
- else
- {
- h->next_weak = weak_hash_tables;
- weak_hash_tables = h;
- }
-
return table;
}
h2->index = Fcopy_sequence (h1->index);
XSET_HASH_TABLE (table, h2);
- /* Maybe add this hash table to the list of all weak hash tables. */
- if (!NILP (h2->weak))
- {
- h2->next_weak = weak_hash_tables;
- weak_hash_tables = h2;
- }
-
return table;
}
\f
-/************************************************************************
- Weak Hash Tables
- ************************************************************************/
-
-/* Sweep weak hash table H. REMOVE_ENTRIES_P means remove
- entries from the table that don't survive the current GC.
- !REMOVE_ENTRIES_P means mark entries that are in use. Value is
- true if anything was marked. */
-
-static bool
-sweep_weak_table (struct Lisp_Hash_Table *h, bool remove_entries_p)
-{
- ptrdiff_t bucket, n;
- bool marked;
-
- n = ASIZE (h->index) & ~ARRAY_MARK_FLAG;
- marked = 0;
-
- for (bucket = 0; bucket < n; ++bucket)
- {
- Lisp_Object idx, next, prev;
-
- /* Follow collision chain, removing entries that
- don't survive this garbage collection. */
- prev = Qnil;
- for (idx = HASH_INDEX (h, bucket); !NILP (idx); idx = next)
- {
- ptrdiff_t i = XFASTINT (idx);
- bool key_known_to_survive_p = survives_gc_p (HASH_KEY (h, i));
- bool value_known_to_survive_p = survives_gc_p (HASH_VALUE (h, i));
- bool remove_p;
-
- if (EQ (h->weak, Qkey))
- remove_p = !key_known_to_survive_p;
- else if (EQ (h->weak, Qvalue))
- remove_p = !value_known_to_survive_p;
- else if (EQ (h->weak, Qkey_or_value))
- remove_p = !(key_known_to_survive_p || value_known_to_survive_p);
- else if (EQ (h->weak, Qkey_and_value))
- remove_p = !(key_known_to_survive_p && value_known_to_survive_p);
- else
- emacs_abort ();
-
- next = HASH_NEXT (h, i);
-
- if (remove_entries_p)
- {
- if (remove_p)
- {
- /* Take out of collision chain. */
- if (NILP (prev))
- set_hash_index_slot (h, bucket, next);
- else
- set_hash_next_slot (h, XFASTINT (prev), next);
-
- /* Add to free list. */
- set_hash_next_slot (h, i, h->next_free);
- h->next_free = idx;
-
- /* Clear key, value, and hash. */
- set_hash_key_slot (h, i, Qnil);
- set_hash_value_slot (h, i, Qnil);
- set_hash_hash_slot (h, i, Qnil);
-
- h->count--;
- }
- else
- {
- prev = idx;
- }
- }
- else
- {
- if (!remove_p)
- {
- /* Make sure key and value survive. */
- if (!key_known_to_survive_p)
- {
- mark_object (HASH_KEY (h, i));
- marked = 1;
- }
-
- if (!value_known_to_survive_p)
- {
- mark_object (HASH_VALUE (h, i));
- marked = 1;
- }
- }
- }
- }
- }
-
- return marked;
-}
-
-/* Remove elements from weak hash tables that don't survive the
- current garbage collection. Remove weak tables that don't survive
- from Vweak_hash_tables. Called from gc_sweep. */
-
-NO_INLINE /* For better stack traces */
-void
-sweep_weak_hash_tables (void)
-{
- struct Lisp_Hash_Table *h, *used, *next;
- bool marked;
-
- /* Mark all keys and values that are in use. Keep on marking until
- there is no more change. This is necessary for cases like
- value-weak table A containing an entry X -> Y, where Y is used in a
- key-weak table B, Z -> Y. If B comes after A in the list of weak
- tables, X -> Y might be removed from A, although when looking at B
- one finds that it shouldn't. */
- do
- {
- marked = 0;
- for (h = weak_hash_tables; h; h = h->next_weak)
- {
- if (h->header.size & ARRAY_MARK_FLAG)
- marked |= sweep_weak_table (h, 0);
- }
- }
- while (marked);
-
- /* Remove tables and entries that aren't used. */
- for (h = weak_hash_tables, used = NULL; h; h = next)
- {
- next = h->next_weak;
-
- if (h->header.size & ARRAY_MARK_FLAG)
- {
- /* TABLE is marked as used. Sweep its contents. */
- if (h->count > 0)
- sweep_weak_table (h, 1);
-
- /* Add table to the list of used weak hash tables. */
- h->next_weak = used;
- used = h;
- }
- }
-
- weak_hash_tables = used;
-}
-
-
-\f
/***********************************************************************
Hash Code Computation
***********************************************************************/
/* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
static Lisp_Object
-secure_hash (Lisp_Object algorithm, 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;
- ptrdiff_t size;
- EMACS_INT start_char = 0, end_char = 0;
- ptrdiff_t start_byte, end_byte;
+ ptrdiff_t size, start_char = 0, start_byte, end_char = 0, end_byte;
register EMACS_INT b, e;
register struct buffer *bp;
EMACS_INT temp;
void
syms_of_fns (void)
{
+#include "fns.x"
+
DEFSYM (Qmd5, "md5");
DEFSYM (Qsha1, "sha1");
DEFSYM (Qsha224, "sha224");
DEFSYM (Qkey_or_value, "key-or-value");
DEFSYM (Qkey_and_value, "key-and-value");
- defsubr (&Ssxhash);
- defsubr (&Smake_hash_table);
- defsubr (&Scopy_hash_table);
- defsubr (&Shash_table_count);
- defsubr (&Shash_table_rehash_size);
- defsubr (&Shash_table_rehash_threshold);
- defsubr (&Shash_table_size);
- defsubr (&Shash_table_test);
- defsubr (&Shash_table_weakness);
- defsubr (&Shash_table_p);
- defsubr (&Sclrhash);
- defsubr (&Sgethash);
- defsubr (&Sputhash);
- defsubr (&Sremhash);
- defsubr (&Smaphash);
- defsubr (&Sdefine_hash_table_test);
-
DEFSYM (Qstring_lessp, "string-lessp");
DEFSYM (Qprovide, "provide");
DEFSYM (Qrequire, "require");
this variable. */);
use_file_dialog = 1;
- defsubr (&Sidentity);
- defsubr (&Srandom);
- defsubr (&Slength);
- defsubr (&Ssafe_length);
- defsubr (&Sstring_bytes);
- defsubr (&Sstring_equal);
- defsubr (&Scompare_strings);
- defsubr (&Sstring_lessp);
- defsubr (&Sappend);
- defsubr (&Sconcat);
- defsubr (&Svconcat);
- defsubr (&Scopy_sequence);
- defsubr (&Sstring_make_multibyte);
- defsubr (&Sstring_make_unibyte);
- defsubr (&Sstring_as_multibyte);
- defsubr (&Sstring_as_unibyte);
- defsubr (&Sstring_to_multibyte);
- defsubr (&Sstring_to_unibyte);
- defsubr (&Scopy_alist);
- defsubr (&Ssubstring);
- defsubr (&Ssubstring_no_properties);
- defsubr (&Snthcdr);
- defsubr (&Snth);
- defsubr (&Selt);
- defsubr (&Smember);
- defsubr (&Smemq);
- defsubr (&Smemql);
- defsubr (&Sassq);
- defsubr (&Sassoc);
- defsubr (&Srassq);
- defsubr (&Srassoc);
- defsubr (&Sdelq);
- defsubr (&Sdelete);
- defsubr (&Snreverse);
- defsubr (&Sreverse);
- defsubr (&Ssort);
- defsubr (&Splist_get);
- defsubr (&Sget);
- defsubr (&Splist_put);
- defsubr (&Sput);
- defsubr (&Slax_plist_get);
- defsubr (&Slax_plist_put);
- defsubr (&Seql);
- defsubr (&Sequal);
- defsubr (&Sequal_including_properties);
- defsubr (&Sfillarray);
- defsubr (&Sclear_string);
- defsubr (&Snconc);
- defsubr (&Smapcar);
- defsubr (&Smapc);
- defsubr (&Smapconcat);
- defsubr (&Syes_or_no_p);
- defsubr (&Sload_average);
- defsubr (&Sfeaturep);
- defsubr (&Srequire);
- defsubr (&Sprovide);
- defsubr (&Splist_member);
- defsubr (&Swidget_put);
- defsubr (&Swidget_get);
- defsubr (&Swidget_apply);
- defsubr (&Sbase64_encode_region);
- defsubr (&Sbase64_decode_region);
- defsubr (&Sbase64_encode_string);
- defsubr (&Sbase64_decode_string);
- defsubr (&Smd5);
- defsubr (&Ssecure_hash);
- defsubr (&Slocale_info);
-
hashtest_eq.name = Qeq;
hashtest_eq.user_hash_function = Qnil;
hashtest_eq.user_cmp_function = Qnil;
HCoop / bpt / emacs.git / blobdiff