X-Git-Url: http://git.chise.org/gitweb/?p=chise%2Fxemacs-chise.git.1;a=blobdiff_plain;f=src%2Ffns.c;h=266783ba50d1d461bd12f818199b0f17a3dc72a8;hp=c1fa079bc974c6b13bc9de20edf4c809fdd2f3ba;hb=6e8f204c9e1f490b2752de46c111744d1deb3ee0;hpb=33c8db8e2477d62fd8734f65475f2ed516167532 diff --git a/src/fns.c b/src/fns.c index c1fa079..266783b 100644 --- a/src/fns.c +++ b/src/fns.c @@ -1,6 +1,7 @@ /* Random utility Lisp functions. Copyright (C) 1985, 86, 87, 93, 94, 95 Free Software Foundation, Inc. Copyright (C) 1995, 1996 Ben Wing. + Copyright (C) 2002, 2003, 2004 MORIOKA Tomohiko This file is part of XEmacs. @@ -36,10 +37,7 @@ Boston, MA 02111-1307, USA. */ #include "lisp.h" -#ifdef HAVE_UNISTD_H -#include -#endif -#include +#include "sysfile.h" #include "buffer.h" #include "bytecode.h" @@ -59,9 +57,10 @@ Lisp_Object Qstring_lessp; Lisp_Object Qidentity; static int internal_old_equal (Lisp_Object, Lisp_Object, int); +Lisp_Object safe_copy_tree (Lisp_Object arg, Lisp_Object vecp, int depth); static Lisp_Object -mark_bit_vector (Lisp_Object obj, void (*markobj) (Lisp_Object)) +mark_bit_vector (Lisp_Object obj) { return Qnil; } @@ -69,13 +68,13 @@ mark_bit_vector (Lisp_Object obj, void (*markobj) (Lisp_Object)) static void print_bit_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) { - int i; - struct Lisp_Bit_Vector *v = XBIT_VECTOR (obj); - int len = bit_vector_length (v); - int last = len; + size_t i; + Lisp_Bit_Vector *v = XBIT_VECTOR (obj); + size_t len = bit_vector_length (v); + size_t last = len; if (INTP (Vprint_length)) - last = min (len, XINT (Vprint_length)); + last = min ((EMACS_INT) len, XINT (Vprint_length)); write_c_string ("#*", printcharfun); for (i = 0; i < last; i++) { @@ -92,8 +91,8 @@ print_bit_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) static int bit_vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { - struct Lisp_Bit_Vector *v1 = XBIT_VECTOR (obj1); - struct Lisp_Bit_Vector *v2 = XBIT_VECTOR (obj2); + Lisp_Bit_Vector *v1 = XBIT_VECTOR (obj1); + Lisp_Bit_Vector *v2 = XBIT_VECTOR (obj2); return ((bit_vector_length (v1) == bit_vector_length (v2)) && !memcmp (v1->bits, v2->bits, @@ -104,17 +103,32 @@ bit_vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) static unsigned long bit_vector_hash (Lisp_Object obj, int depth) { - struct Lisp_Bit_Vector *v = XBIT_VECTOR (obj); + Lisp_Bit_Vector *v = XBIT_VECTOR (obj); return HASH2 (bit_vector_length (v), memory_hash (v->bits, BIT_VECTOR_LONG_STORAGE (bit_vector_length (v)) * sizeof (long))); } -DEFINE_BASIC_LRECORD_IMPLEMENTATION ("bit-vector", bit_vector, - mark_bit_vector, print_bit_vector, 0, - bit_vector_equal, bit_vector_hash, - struct Lisp_Bit_Vector); +static size_t +size_bit_vector (const void *lheader) +{ + Lisp_Bit_Vector *v = (Lisp_Bit_Vector *) lheader; + return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, unsigned long, bits, + BIT_VECTOR_LONG_STORAGE (bit_vector_length (v))); +} + +static const struct lrecord_description bit_vector_description[] = { + { XD_LISP_OBJECT, offsetof (Lisp_Bit_Vector, next) }, + { XD_END } +}; + + +DEFINE_BASIC_LRECORD_SEQUENCE_IMPLEMENTATION ("bit-vector", bit_vector, + mark_bit_vector, print_bit_vector, 0, + bit_vector_equal, bit_vector_hash, + bit_vector_description, size_bit_vector, + Lisp_Bit_Vector); DEFUN ("identity", Fidentity, 1, 1, 0, /* Return the argument unchanged. @@ -130,7 +144,7 @@ extern void seed_random (long arg); DEFUN ("random", Frandom, 0, 1, 0, /* Return a pseudo-random number. All integers representable in Lisp are equally likely. - On most systems, this is 28 bits' worth. + On most systems, this is 31 bits' worth. With positive integer argument N, return random number in interval [0,N). With argument t, set the random number seed from the current time and pid. */ @@ -150,7 +164,7 @@ With argument t, set the random number seed from the current time and pid. it's possible to get a quotient larger than limit; discarding these values eliminates the bias that would otherwise appear when using a large limit. */ - denominator = ((unsigned long)1 << VALBITS) / XINT (limit); + denominator = ((unsigned long)1 << INT_VALBITS) / XINT (limit); do val = get_random () / denominator; while (val >= XINT (limit)); @@ -177,7 +191,7 @@ length_with_bytecode_hack (Lisp_Object seq) return XINT (Flength (seq)); else { - struct Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (seq); + Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (seq); return (f->flags.interactivep ? COMPILED_INTERACTIVE : f->flags.domainp ? COMPILED_DOMAIN : @@ -189,7 +203,7 @@ length_with_bytecode_hack (Lisp_Object seq) #endif /* LOSING_BYTECODE */ void -check_losing_bytecode (CONST char *function, Lisp_Object seq) +check_losing_bytecode (const char *function, Lisp_Object seq) { if (COMPILED_FUNCTIONP (seq)) error_with_frob @@ -208,7 +222,7 @@ Return the length of vector, bit vector, list or string SEQUENCE. return make_int (XSTRING_CHAR_LENGTH (sequence)); else if (CONSP (sequence)) { - int len; + size_t len; GET_EXTERNAL_LIST_LENGTH (sequence, len); return make_int (len); } @@ -235,7 +249,7 @@ which is at least the number of distinct elements. (list)) { Lisp_Object hare, tortoise; - int len; + size_t len; for (hare = tortoise = list, len = 0; CONSP (hare) && (! EQ (hare, tortoise) || len == 0); @@ -258,25 +272,25 @@ strings, but this is not the case under FSF Emacs 19. In FSF Emacs 20 `equal' is the same as in XEmacs, in that respect.) Symbols are also allowed; their print names are used instead. */ - (s1, s2)) + (string1, string2)) { Bytecount len; - struct Lisp_String *p1, *p2; + Lisp_String *p1, *p2; - if (SYMBOLP (s1)) - p1 = XSYMBOL (s1)->name; + if (SYMBOLP (string1)) + p1 = XSYMBOL (string1)->name; else { - CHECK_STRING (s1); - p1 = XSTRING (s1); + CHECK_STRING (string1); + p1 = XSTRING (string1); } - if (SYMBOLP (s2)) - p2 = XSYMBOL (s2)->name; + if (SYMBOLP (string2)) + p2 = XSYMBOL (string2)->name; else { - CHECK_STRING (s2); - p2 = XSTRING (s2); + CHECK_STRING (string2); + p2 = XSTRING (string2); } return (((len = string_length (p1)) == string_length (p2)) && @@ -306,26 +320,26 @@ it is quite likely that a collation table exists (or will exist) for Unicode. When Unicode support is added to XEmacs/Mule, this problem may be solved. */ - (s1, s2)) + (string1, string2)) { - struct Lisp_String *p1, *p2; + Lisp_String *p1, *p2; Charcount end, len2; int i; - if (SYMBOLP (s1)) - p1 = XSYMBOL (s1)->name; + if (SYMBOLP (string1)) + p1 = XSYMBOL (string1)->name; else { - CHECK_STRING (s1); - p1 = XSTRING (s1); + CHECK_STRING (string1); + p1 = XSTRING (string1); } - if (SYMBOLP (s2)) - p2 = XSYMBOL (s2)->name; + if (SYMBOLP (string2)) + p2 = XSYMBOL (string2)->name; else { - CHECK_STRING (s2); - p2 = XSTRING (s2); + CHECK_STRING (string2); + p2 = XSTRING (string2); } end = string_char_length (p1); @@ -339,32 +353,41 @@ may be solved. properly, it would still not work because strcoll() does not handle multiple locales. This is the fundamental flaw in the locale model. */ - Bytecount bcend = charcount_to_bytecount (string_data (p1), end); - /* Compare strings using collation order of locale. */ - /* Need to be tricky to handle embedded nulls. */ + { + Bytecount bcend = charcount_to_bytecount (string_data (p1), end); + /* Compare strings using collation order of locale. */ + /* Need to be tricky to handle embedded nulls. */ - for (i = 0; i < bcend; i += strlen((char *) string_data (p1) + i) + 1) - { - int val = strcoll ((char *) string_data (p1) + i, - (char *) string_data (p2) + i); - if (val < 0) - return Qt; - if (val > 0) - return Qnil; - } + for (i = 0; i < bcend; i += strlen((char *) string_data (p1) + i) + 1) + { + int val = strcoll ((char *) string_data (p1) + i, + (char *) string_data (p2) + i); + if (val < 0) + return Qt; + if (val > 0) + return Qnil; + } + } #else /* not I18N2, or MULE */ - /* #### It is not really necessary to do this: We could compare - byte-by-byte and still get a reasonable comparison, since this - would compare characters with a charset in the same way. - With a little rearrangement of the leading bytes, we could - make most inter-charset comparisons work out the same, too; - even if some don't, this is not a big deal because inter-charset - comparisons aren't really well-defined anyway. */ - for (i = 0; i < end; i++) - { - if (string_char (p1, i) != string_char (p2, i)) - return string_char (p1, i) < string_char (p2, i) ? Qt : Qnil; - } + { + Bufbyte *ptr1 = string_data (p1); + Bufbyte *ptr2 = string_data (p2); + + /* #### It is not really necessary to do this: We could compare + byte-by-byte and still get a reasonable comparison, since this + would compare characters with a charset in the same way. With + a little rearrangement of the leading bytes, we could make most + inter-charset comparisons work out the same, too; even if some + don't, this is not a big deal because inter-charset comparisons + aren't really well-defined anyway. */ + for (i = 0; i < end; i++) + { + if (charptr_emchar (ptr1) != charptr_emchar (ptr2)) + return charptr_emchar (ptr1) < charptr_emchar (ptr2) ? Qt : Qnil; + INC_CHARPTR (ptr1); + INC_CHARPTR (ptr2); + } + } #endif /* not I18N2, or MULE */ /* Can't do i < len2 because then comparison between "foo" and "foo^@" won't work right in I18N2 case */ @@ -378,7 +401,7 @@ of the string are changed (e.g. with `aset'). It wraps around occasionally. */ (string)) { - struct Lisp_String *s; + Lisp_String *s; CHECK_STRING (string); s = XSTRING (string); @@ -391,7 +414,7 @@ of the string are changed (e.g. with `aset'). It wraps around occasionally. void bump_string_modiff (Lisp_Object str) { - struct Lisp_String *s = XSTRING (str); + Lisp_String *s = XSTRING (str); Lisp_Object *ptr = &s->plist; #ifdef I18N3 @@ -414,40 +437,40 @@ static Lisp_Object concat (int nargs, Lisp_Object *args, int last_special); Lisp_Object -concat2 (Lisp_Object s1, Lisp_Object s2) +concat2 (Lisp_Object string1, Lisp_Object string2) { Lisp_Object args[2]; - args[0] = s1; - args[1] = s2; + args[0] = string1; + args[1] = string2; return concat (2, args, c_string, 0); } Lisp_Object -concat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3) +concat3 (Lisp_Object string1, Lisp_Object string2, Lisp_Object string3) { Lisp_Object args[3]; - args[0] = s1; - args[1] = s2; - args[2] = s3; + args[0] = string1; + args[1] = string2; + args[2] = string3; return concat (3, args, c_string, 0); } Lisp_Object -vconcat2 (Lisp_Object s1, Lisp_Object s2) +vconcat2 (Lisp_Object vec1, Lisp_Object vec2) { Lisp_Object args[2]; - args[0] = s1; - args[1] = s2; + args[0] = vec1; + args[1] = vec2; return concat (2, args, c_vector, 0); } Lisp_Object -vconcat3 (Lisp_Object s1, Lisp_Object s2, Lisp_Object s3) +vconcat3 (Lisp_Object vec1, Lisp_Object vec2, Lisp_Object vec3) { Lisp_Object args[3]; - args[0] = s1; - args[1] = s2; - args[2] = s3; + args[0] = vec1; + args[1] = vec2; + args[2] = vec3; return concat (3, args, c_vector, 0); } @@ -506,7 +529,7 @@ copy_list (Lisp_Object list) Lisp_Object list_copy = Fcons (XCAR (list), XCDR (list)); Lisp_Object last = list_copy; Lisp_Object hare, tortoise; - int len; + size_t len; for (tortoise = hare = XCDR (list), len = 1; CONSP (hare); @@ -689,7 +712,8 @@ concat (int nargs, Lisp_Object *args, string_result_ptr = string_result; break; default: - abort (); + val = Qnil; + ABORT (); } } @@ -841,6 +865,15 @@ are not copied. */ (arg, vecp)) { + return safe_copy_tree (arg, vecp, 0); +} + +Lisp_Object +safe_copy_tree (Lisp_Object arg, Lisp_Object vecp, int depth) +{ + if (depth > 200) + signal_simple_error ("Stack overflow in copy-tree", arg); + if (CONSP (arg)) { Lisp_Object rest; @@ -850,9 +883,9 @@ are not copied. Lisp_Object elt = XCAR (rest); QUIT; if (CONSP (elt) || VECTORP (elt)) - XCAR (rest) = Fcopy_tree (elt, vecp); + XCAR (rest) = safe_copy_tree (elt, vecp, depth + 1); if (VECTORP (XCDR (rest))) /* hack for (a b . [c d]) */ - XCDR (rest) = Fcopy_tree (XCDR (rest), vecp); + XCDR (rest) = safe_copy_tree (XCDR (rest), vecp, depth +1); rest = XCDR (rest); } } @@ -866,116 +899,113 @@ are not copied. Lisp_Object elt = XVECTOR_DATA (arg) [j]; QUIT; if (CONSP (elt) || VECTORP (elt)) - XVECTOR_DATA (arg) [j] = Fcopy_tree (elt, vecp); + XVECTOR_DATA (arg) [j] = safe_copy_tree (elt, vecp, depth + 1); } } return arg; } DEFUN ("substring", Fsubstring, 2, 3, 0, /* -Return a substring of STRING, starting at index FROM and ending before TO. -TO may be nil or omitted; then the substring runs to the end of STRING. -If FROM or TO is negative, it counts from the end. -Relevant parts of the string-extent-data are copied in the new string. +Return the substring of STRING starting at START and ending before END. +END may be nil or omitted; then the substring runs to the end of STRING. +If START or END is negative, it counts from the end. +Relevant parts of the string-extent-data are copied to the new string. */ - (string, from, to)) + (string, start, end)) { - Charcount ccfr, ccto; - Bytecount bfr, bto; + Charcount ccstart, ccend; + Bytecount bstart, blen; Lisp_Object val; CHECK_STRING (string); - CHECK_INT (from); - get_string_range_char (string, from, to, &ccfr, &ccto, + CHECK_INT (start); + get_string_range_char (string, start, end, &ccstart, &ccend, GB_HISTORICAL_STRING_BEHAVIOR); - bfr = charcount_to_bytecount (XSTRING_DATA (string), ccfr); - bto = charcount_to_bytecount (XSTRING_DATA (string), ccto); - val = make_string (XSTRING_DATA (string) + bfr, bto - bfr); - /* Copy any applicable extent information into the new string: */ - copy_string_extents (val, string, 0, bfr, bto - bfr); + bstart = charcount_to_bytecount (XSTRING_DATA (string), ccstart); + blen = charcount_to_bytecount (XSTRING_DATA (string) + bstart, ccend - ccstart); + val = make_string (XSTRING_DATA (string) + bstart, blen); + /* Copy any applicable extent information into the new string. */ + copy_string_extents (val, string, 0, bstart, blen); return val; } DEFUN ("subseq", Fsubseq, 2, 3, 0, /* -Return a subsequence of SEQ, starting at index FROM and ending before TO. -TO may be nil or omitted; then the subsequence runs to the end of SEQ. -If FROM or TO is negative, it counts from the end. -The resulting subsequence is always the same type as the original - sequence. -If SEQ is a string, relevant parts of the string-extent-data are copied - to the new string. +Return the subsequence of SEQUENCE starting at START and ending before END. +END may be omitted; then the subsequence runs to the end of SEQUENCE. +If START or END is negative, it counts from the end. +The returned subsequence is always of the same type as SEQUENCE. +If SEQUENCE is a string, relevant parts of the string-extent-data +are copied to the new string. */ - (seq, from, to)) + (sequence, start, end)) { - int len, f, t; + EMACS_INT len, s, e; - if (STRINGP (seq)) - return Fsubstring (seq, from, to); - - if (!LISTP (seq) && !VECTORP (seq) && !BIT_VECTORP (seq)) - { - check_losing_bytecode ("subseq", seq); - seq = wrong_type_argument (Qsequencep, seq); - } + if (STRINGP (sequence)) + return Fsubstring (sequence, start, end); - len = XINT (Flength (seq)); + len = XINT (Flength (sequence)); - CHECK_INT (from); - f = XINT (from); - if (f < 0) - f = len + f; + CHECK_INT (start); + s = XINT (start); + if (s < 0) + s = len + s; - if (NILP (to)) - t = len; + if (NILP (end)) + e = len; else { - CHECK_INT (to); - t = XINT (to); - if (t < 0) - t = len + t; + CHECK_INT (end); + e = XINT (end); + if (e < 0) + e = len + e; } - if (!(0 <= f && f <= t && t <= len)) - args_out_of_range_3 (seq, make_int (f), make_int (t)); + if (!(0 <= s && s <= e && e <= len)) + args_out_of_range_3 (sequence, make_int (s), make_int (e)); - if (VECTORP (seq)) + if (VECTORP (sequence)) { - Lisp_Object result = make_vector (t - f, Qnil); - int i; - Lisp_Object *in_elts = XVECTOR_DATA (seq); + Lisp_Object result = make_vector (e - s, Qnil); + EMACS_INT i; + Lisp_Object *in_elts = XVECTOR_DATA (sequence); Lisp_Object *out_elts = XVECTOR_DATA (result); - for (i = f; i < t; i++) - out_elts[i - f] = in_elts[i]; + for (i = s; i < e; i++) + out_elts[i - s] = in_elts[i]; return result; } - - if (LISTP (seq)) + else if (LISTP (sequence)) { Lisp_Object result = Qnil; - int i; + EMACS_INT i; - seq = Fnthcdr (make_int (f), seq); + sequence = Fnthcdr (make_int (s), sequence); - for (i = f; i < t; i++) + for (i = s; i < e; i++) { - result = Fcons (Fcar (seq), result); - seq = Fcdr (seq); + result = Fcons (Fcar (sequence), result); + sequence = Fcdr (sequence); } return Fnreverse (result); } + else if (BIT_VECTORP (sequence)) + { + Lisp_Object result = make_bit_vector (e - s, Qzero); + EMACS_INT i; - /* bit vector */ - { - Lisp_Object result = make_bit_vector (t - f, Qzero); - int i; - - for (i = f; i < t; i++) - set_bit_vector_bit (XBIT_VECTOR (result), i - f, - bit_vector_bit (XBIT_VECTOR (seq), i)); - return result; - } + for (i = s; i < e; i++) + set_bit_vector_bit (XBIT_VECTOR (result), i - s, + bit_vector_bit (XBIT_VECTOR (sequence), i)); + return result; + } + else + { + ABORT (); /* unreachable, since Flength (sequence) did not get + an error */ + return Qnil; + } } @@ -984,7 +1014,7 @@ Take cdr N times on LIST, and return the result. */ (n, list)) { - REGISTER int i; + REGISTER size_t i; REGISTER Lisp_Object tail = list; CHECK_NATNUM (n); for (i = XINT (n); i; i--) @@ -1043,7 +1073,7 @@ Return element of SEQUENCE at index N. #ifdef LOSING_BYTECODE else if (COMPILED_FUNCTIONP (sequence)) { - int idx = XINT (n); + EMACS_INT idx = XINT (n); if (idx < 0) { lose: @@ -1095,7 +1125,7 @@ If N is greater than the length of LIST, then LIST itself is returned. */ (list, n)) { - int int_n, count; + EMACS_INT int_n, count; Lisp_Object retval, tortoise, hare; CHECK_LIST (list); @@ -1131,7 +1161,7 @@ If LIST has N or fewer elements, nil is returned and LIST is unmodified. */ (list, n)) { - int int_n; + EMACS_INT int_n; CHECK_LIST (list); @@ -1166,7 +1196,7 @@ If LIST has N or fewer elements, nil is returned. */ (list, n)) { - int int_n; + EMACS_INT int_n; CHECK_LIST (list); @@ -1201,7 +1231,6 @@ The value is actually the tail of LIST whose car is ELT. */ (elt, list)) { - Lisp_Object list_elt, tail; EXTERNAL_LIST_LOOP_3 (list_elt, list, tail) { if (internal_equal (elt, list_elt, 0)) @@ -1218,7 +1247,6 @@ Do not use it. */ (elt, list)) { - Lisp_Object list_elt, tail; EXTERNAL_LIST_LOOP_3 (list_elt, list, tail) { if (internal_old_equal (elt, list_elt, 0)) @@ -1233,7 +1261,6 @@ The value is actually the tail of LIST whose car is ELT. */ (elt, list)) { - Lisp_Object list_elt, tail; EXTERNAL_LIST_LOOP_3 (list_elt, list, tail) { if (EQ_WITH_EBOLA_NOTICE (elt, list_elt)) @@ -1250,7 +1277,6 @@ Do not use it. */ (elt, list)) { - Lisp_Object list_elt, tail; EXTERNAL_LIST_LOOP_3 (list_elt, list, tail) { if (HACKEQ_UNSAFE (elt, list_elt)) @@ -1262,7 +1288,6 @@ Do not use it. Lisp_Object memq_no_quit (Lisp_Object elt, Lisp_Object list) { - Lisp_Object list_elt, tail; LIST_LOOP_3 (list_elt, list, tail) { if (EQ_WITH_EBOLA_NOTICE (elt, list_elt)) @@ -1272,14 +1297,13 @@ memq_no_quit (Lisp_Object elt, Lisp_Object list) } DEFUN ("assoc", Fassoc, 2, 2, 0, /* -Return non-nil if KEY is `equal' to the car of an element of LIST. -The value is actually the element of LIST whose car equals KEY. +Return non-nil if KEY is `equal' to the car of an element of ALIST. +The value is actually the element of ALIST whose car equals KEY. */ - (key, list)) + (key, alist)) { /* This function can GC. */ - Lisp_Object elt, elt_car, elt_cdr; - EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list) + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) { if (internal_equal (key, elt_car, 0)) return elt; @@ -1288,14 +1312,13 @@ The value is actually the element of LIST whose car equals KEY. } DEFUN ("old-assoc", Fold_assoc, 2, 2, 0, /* -Return non-nil if KEY is `old-equal' to the car of an element of LIST. -The value is actually the element of LIST whose car equals KEY. +Return non-nil if KEY is `old-equal' to the car of an element of ALIST. +The value is actually the element of ALIST whose car equals KEY. */ - (key, list)) + (key, alist)) { /* This function can GC. */ - Lisp_Object elt, elt_car, elt_cdr; - EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list) + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) { if (internal_old_equal (key, elt_car, 0)) return elt; @@ -1304,22 +1327,21 @@ The value is actually the element of LIST whose car equals KEY. } Lisp_Object -assoc_no_quit (Lisp_Object key, Lisp_Object list) +assoc_no_quit (Lisp_Object key, Lisp_Object alist) { int speccount = specpdl_depth (); specbind (Qinhibit_quit, Qt); - return unbind_to (speccount, Fassoc (key, list)); + return unbind_to (speccount, Fassoc (key, alist)); } DEFUN ("assq", Fassq, 2, 2, 0, /* -Return non-nil if KEY is `eq' to the car of an element of LIST. -The value is actually the element of LIST whose car is KEY. -Elements of LIST that are not conses are ignored. +Return non-nil if KEY is `eq' to the car of an element of ALIST. +The value is actually the element of ALIST whose car is KEY. +Elements of ALIST that are not conses are ignored. */ - (key, list)) + (key, alist)) { - Lisp_Object elt, elt_car, elt_cdr; - EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list) + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) { if (EQ_WITH_EBOLA_NOTICE (key, elt_car)) return elt; @@ -1328,16 +1350,15 @@ Elements of LIST that are not conses are ignored. } DEFUN ("old-assq", Fold_assq, 2, 2, 0, /* -Return non-nil if KEY is `old-eq' to the car of an element of LIST. -The value is actually the element of LIST whose car is KEY. -Elements of LIST that are not conses are ignored. +Return non-nil if KEY is `old-eq' to the car of an element of ALIST. +The value is actually the element of ALIST whose car is KEY. +Elements of ALIST that are not conses are ignored. This function is provided only for byte-code compatibility with v19. Do not use it. */ - (key, list)) + (key, alist)) { - Lisp_Object elt, elt_car, elt_cdr; - EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list) + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) { if (HACKEQ_UNSAFE (key, elt_car)) return elt; @@ -1349,11 +1370,10 @@ Do not use it. Use only on lists known never to be circular. */ Lisp_Object -assq_no_quit (Lisp_Object key, Lisp_Object list) +assq_no_quit (Lisp_Object key, Lisp_Object alist) { /* This cannot GC. */ - Lisp_Object elt; - LIST_LOOP_2 (elt, list) + LIST_LOOP_2 (elt, alist) { Lisp_Object elt_car = XCAR (elt); if (EQ_WITH_EBOLA_NOTICE (key, elt_car)) @@ -1363,75 +1383,70 @@ assq_no_quit (Lisp_Object key, Lisp_Object list) } DEFUN ("rassoc", Frassoc, 2, 2, 0, /* -Return non-nil if KEY is `equal' to the cdr of an element of LIST. -The value is actually the element of LIST whose cdr equals KEY. +Return non-nil if VALUE is `equal' to the cdr of an element of ALIST. +The value is actually the element of ALIST whose cdr equals VALUE. */ - (key, list)) + (value, alist)) { - Lisp_Object elt, elt_car, elt_cdr; - EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list) + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) { - if (internal_equal (key, elt_cdr, 0)) + if (internal_equal (value, elt_cdr, 0)) return elt; } return Qnil; } DEFUN ("old-rassoc", Fold_rassoc, 2, 2, 0, /* -Return non-nil if KEY is `old-equal' to the cdr of an element of LIST. -The value is actually the element of LIST whose cdr equals KEY. +Return non-nil if VALUE is `old-equal' to the cdr of an element of ALIST. +The value is actually the element of ALIST whose cdr equals VALUE. */ - (key, list)) + (value, alist)) { - Lisp_Object elt, elt_car, elt_cdr; - EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list) + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) { - if (internal_old_equal (key, elt_cdr, 0)) + if (internal_old_equal (value, elt_cdr, 0)) return elt; } return Qnil; } DEFUN ("rassq", Frassq, 2, 2, 0, /* -Return non-nil if KEY is `eq' to the cdr of an element of LIST. -The value is actually the element of LIST whose cdr is KEY. +Return non-nil if VALUE is `eq' to the cdr of an element of ALIST. +The value is actually the element of ALIST whose cdr is VALUE. */ - (key, list)) + (value, alist)) { - Lisp_Object elt, elt_car, elt_cdr; - EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list) + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) { - if (EQ_WITH_EBOLA_NOTICE (key, elt_cdr)) + if (EQ_WITH_EBOLA_NOTICE (value, elt_cdr)) return elt; } return Qnil; } DEFUN ("old-rassq", Fold_rassq, 2, 2, 0, /* -Return non-nil if KEY is `old-eq' to the cdr of an element of LIST. -The value is actually the element of LIST whose cdr is KEY. +Return non-nil if VALUE is `old-eq' to the cdr of an element of ALIST. +The value is actually the element of ALIST whose cdr is VALUE. */ - (key, list)) + (value, alist)) { - Lisp_Object elt, elt_car, elt_cdr; - EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, list) + EXTERNAL_ALIST_LOOP_4 (elt, elt_car, elt_cdr, alist) { - if (HACKEQ_UNSAFE (key, elt_cdr)) + if (HACKEQ_UNSAFE (value, elt_cdr)) return elt; } return Qnil; } -/* Like Frassq, but caller must ensure that LIST is properly +/* Like Frassq, but caller must ensure that ALIST is properly nil-terminated and ebola-free. */ Lisp_Object -rassq_no_quit (Lisp_Object key, Lisp_Object list) +rassq_no_quit (Lisp_Object value, Lisp_Object alist) { - Lisp_Object elt; - LIST_LOOP_2 (elt, list) + LIST_LOOP_2 (elt, alist) { Lisp_Object elt_cdr = XCDR (elt); - if (EQ_WITH_EBOLA_NOTICE (key, elt_cdr)) + if (EQ_WITH_EBOLA_NOTICE (value, elt_cdr)) return elt; } return Qnil; @@ -1448,7 +1463,6 @@ Also see: `remove'. */ (elt, list)) { - Lisp_Object list_elt; EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list, (internal_equal (elt, list_elt, 0))); return list; @@ -1463,7 +1477,6 @@ of changing the value of `foo'. */ (elt, list)) { - Lisp_Object list_elt; EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list, (internal_old_equal (elt, list_elt, 0))); return list; @@ -1478,7 +1491,6 @@ changing the value of `foo'. */ (elt, list)) { - Lisp_Object list_elt; EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list, (EQ_WITH_EBOLA_NOTICE (elt, list_elt))); return list; @@ -1493,7 +1505,6 @@ changing the value of `foo'. */ (elt, list)) { - Lisp_Object list_elt; EXTERNAL_LIST_LOOP_DELETE_IF (list_elt, list, (HACKEQ_UNSAFE (elt, list_elt))); return list; @@ -1505,7 +1516,6 @@ changing the value of `foo'. Lisp_Object delq_no_quit (Lisp_Object elt, Lisp_Object list) { - Lisp_Object list_elt; LIST_LOOP_DELETE_IF (list_elt, list, (EQ_WITH_EBOLA_NOTICE (elt, list_elt))); return list; @@ -1547,98 +1557,92 @@ delq_no_quit_and_free_cons (Lisp_Object elt, Lisp_Object list) } DEFUN ("remassoc", Fremassoc, 2, 2, 0, /* -Delete by side effect any elements of LIST whose car is `equal' to KEY. -The modified LIST is returned. If the first member of LIST has a car +Delete by side effect any elements of ALIST whose car is `equal' to KEY. +The modified ALIST is returned. If the first member of ALIST has a car that is `equal' to KEY, there is no way to remove it by side effect; therefore, write `(setq foo (remassoc key foo))' to be sure of changing the value of `foo'. */ - (key, list)) + (key, alist)) { - Lisp_Object elt; - EXTERNAL_LIST_LOOP_DELETE_IF (elt, list, + EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist, (CONSP (elt) && internal_equal (key, XCAR (elt), 0))); - return list; + return alist; } Lisp_Object -remassoc_no_quit (Lisp_Object key, Lisp_Object list) +remassoc_no_quit (Lisp_Object key, Lisp_Object alist) { int speccount = specpdl_depth (); specbind (Qinhibit_quit, Qt); - return unbind_to (speccount, Fremassoc (key, list)); + return unbind_to (speccount, Fremassoc (key, alist)); } DEFUN ("remassq", Fremassq, 2, 2, 0, /* -Delete by side effect any elements of LIST whose car is `eq' to KEY. -The modified LIST is returned. If the first member of LIST has a car +Delete by side effect any elements of ALIST whose car is `eq' to KEY. +The modified ALIST is returned. If the first member of ALIST has a car that is `eq' to KEY, there is no way to remove it by side effect; therefore, write `(setq foo (remassq key foo))' to be sure of changing the value of `foo'. */ - (key, list)) + (key, alist)) { - Lisp_Object elt; - EXTERNAL_LIST_LOOP_DELETE_IF (elt, list, + EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist, (CONSP (elt) && EQ_WITH_EBOLA_NOTICE (key, XCAR (elt)))); - return list; + return alist; } /* no quit, no errors; be careful */ Lisp_Object -remassq_no_quit (Lisp_Object key, Lisp_Object list) +remassq_no_quit (Lisp_Object key, Lisp_Object alist) { - Lisp_Object elt; - LIST_LOOP_DELETE_IF (elt, list, + LIST_LOOP_DELETE_IF (elt, alist, (CONSP (elt) && EQ_WITH_EBOLA_NOTICE (key, XCAR (elt)))); - return list; + return alist; } DEFUN ("remrassoc", Fremrassoc, 2, 2, 0, /* -Delete by side effect any elements of LIST whose cdr is `equal' to VALUE. -The modified LIST is returned. If the first member of LIST has a car +Delete by side effect any elements of ALIST whose cdr is `equal' to VALUE. +The modified ALIST is returned. If the first member of ALIST has a car that is `equal' to VALUE, there is no way to remove it by side effect; therefore, write `(setq foo (remrassoc value foo))' to be sure of changing the value of `foo'. */ - (value, list)) + (value, alist)) { - Lisp_Object elt; - EXTERNAL_LIST_LOOP_DELETE_IF (elt, list, + EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist, (CONSP (elt) && internal_equal (value, XCDR (elt), 0))); - return list; + return alist; } DEFUN ("remrassq", Fremrassq, 2, 2, 0, /* -Delete by side effect any elements of LIST whose cdr is `eq' to VALUE. -The modified LIST is returned. If the first member of LIST has a car +Delete by side effect any elements of ALIST whose cdr is `eq' to VALUE. +The modified ALIST is returned. If the first member of ALIST has a car that is `eq' to VALUE, there is no way to remove it by side effect; therefore, write `(setq foo (remrassq value foo))' to be sure of changing the value of `foo'. */ - (value, list)) + (value, alist)) { - Lisp_Object elt; - EXTERNAL_LIST_LOOP_DELETE_IF (elt, list, + EXTERNAL_LIST_LOOP_DELETE_IF (elt, alist, (CONSP (elt) && EQ_WITH_EBOLA_NOTICE (value, XCDR (elt)))); - return list; + return alist; } /* Like Fremrassq, fast and unsafe; be careful */ Lisp_Object -remrassq_no_quit (Lisp_Object value, Lisp_Object list) +remrassq_no_quit (Lisp_Object value, Lisp_Object alist) { - Lisp_Object elt; - LIST_LOOP_DELETE_IF (elt, list, + LIST_LOOP_DELETE_IF (elt, alist, (CONSP (elt) && EQ_WITH_EBOLA_NOTICE (value, XCDR (elt)))); - return list; + return alist; } DEFUN ("nreverse", Fnreverse, 1, 1, 0, /* @@ -1674,7 +1678,6 @@ See also the function `nreverse', which is used more often. (list)) { Lisp_Object reversed_list = Qnil; - Lisp_Object elt; EXTERNAL_LIST_LOOP_2 (elt, list) { reversed_list = Fcons (elt, reversed_list); @@ -1697,12 +1700,11 @@ list_sort (Lisp_Object list, Lisp_Object back, tem; Lisp_Object front = list; Lisp_Object len = Flength (list); - int length = XINT (len); - if (length < 2) + if (XINT (len) < 2) return list; - XSETINT (len, (length / 2) - 1); + len = make_int (XINT (len) / 2 - 1); tem = Fnthcdr (len, list); back = Fcdr (tem); Fsetcdr (tem, Qnil); @@ -1743,9 +1745,9 @@ Returns the sorted list. LIST is modified by side effects. PREDICATE is called with two elements of LIST, and should return T if the first element is "less" than the second. */ - (list, pred)) + (list, predicate)) { - return list_sort (list, pred, merge_pred_function); + return list_sort (list, predicate, merge_pred_function); } Lisp_Object @@ -1834,7 +1836,7 @@ int plists_differ (Lisp_Object a, Lisp_Object b, int nil_means_not_present, int laxp, int depth) { - int eqp = (depth == -1); /* -1 as depth means us eq, not equal. */ + int eqp = (depth == -1); /* -1 as depth means use eq, not equal. */ int la, lb, m, i, fill; Lisp_Object *keys, *vals; char *flags; @@ -1878,10 +1880,10 @@ plists_differ (Lisp_Object a, Lisp_Object b, int nil_means_not_present, { if (!laxp ? EQ (k, keys [i]) : internal_equal (k, keys [i], depth)) { - if ((eqp - /* We narrowly escaped being Ebolified here. */ - ? !EQ_WITH_EBOLA_NOTICE (v, vals [i]) - : !internal_equal (v, vals [i], depth))) + if (eqp + /* We narrowly escaped being Ebolified here. */ + ? !EQ_WITH_EBOLA_NOTICE (v, vals [i]) + : !internal_equal (v, vals [i], depth)) /* a property in B has a different value than in A */ goto MISMATCH; flags [i] = 1; @@ -2076,8 +2078,6 @@ static Lisp_Object bad_bad_turtle (Lisp_Object *plist, Lisp_Object *badplace, Error_behavior errb) { if (ERRB_EQ (errb, ERROR_ME)) - /* #### Eek, this will probably result in another error - when PLIST is printed out */ return Fsignal (Qcircular_property_list, list1 (*plist)); else { @@ -2277,51 +2277,54 @@ external_remprop (Lisp_Object *plist, Lisp_Object property, DEFUN ("plist-get", Fplist_get, 2, 3, 0, /* Extract a value from a property list. PLIST is a property list, which is a list of the form -\(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value -corresponding to the given PROP, or DEFAULT if PROP is not -one of the properties on the list. +\(PROPERTY1 VALUE1 PROPERTY2 VALUE2...). +PROPERTY is usually a symbol. +This function returns the value corresponding to the PROPERTY, +or DEFAULT if PROPERTY is not one of the properties on the list. */ - (plist, prop, default_)) + (plist, property, default_)) { - Lisp_Object val = external_plist_get (&plist, prop, 0, ERROR_ME); - return UNBOUNDP (val) ? default_ : val; + Lisp_Object value = external_plist_get (&plist, property, 0, ERROR_ME); + return UNBOUNDP (value) ? default_ : value; } DEFUN ("plist-put", Fplist_put, 3, 3, 0, /* -Change value in PLIST of PROP to VAL. -PLIST is a property list, which is a list of the form \(PROP1 VALUE1 -PROP2 VALUE2 ...). PROP is usually a symbol and VAL is any object. -If PROP is already a property on the list, its value is set to VAL, -otherwise the new PROP VAL pair is added. The new plist is returned; -use `(setq x (plist-put x prop val))' to be sure to use the new value. -The PLIST is modified by side effects. +Change value in PLIST of PROPERTY to VALUE. +PLIST is a property list, which is a list of the form +\(PROPERTY1 VALUE1 PROPERTY2 VALUE2 ...). +PROPERTY is usually a symbol and VALUE is any object. +If PROPERTY is already a property on the list, its value is set to VALUE, +otherwise the new PROPERTY VALUE pair is added. +The new plist is returned; use `(setq x (plist-put x property value))' +to be sure to use the new value. PLIST is modified by side effect. */ - (plist, prop, val)) + (plist, property, value)) { - external_plist_put (&plist, prop, val, 0, ERROR_ME); + external_plist_put (&plist, property, value, 0, ERROR_ME); return plist; } DEFUN ("plist-remprop", Fplist_remprop, 2, 2, 0, /* -Remove from PLIST the property PROP and its value. -PLIST is a property list, which is a list of the form \(PROP1 VALUE1 -PROP2 VALUE2 ...). PROP is usually a symbol. The new plist is -returned; use `(setq x (plist-remprop x prop val))' to be sure to use -the new value. The PLIST is modified by side effects. +Remove from PLIST the property PROPERTY and its value. +PLIST is a property list, which is a list of the form +\(PROPERTY1 VALUE1 PROPERTY2 VALUE2 ...). +PROPERTY is usually a symbol. +The new plist is returned; use `(setq x (plist-remprop x property))' +to be sure to use the new value. PLIST is modified by side effect. */ - (plist, prop)) + (plist, property)) { - external_remprop (&plist, prop, 0, ERROR_ME); + external_remprop (&plist, property, 0, ERROR_ME); return plist; } DEFUN ("plist-member", Fplist_member, 2, 2, 0, /* -Return t if PROP has a value specified in PLIST. +Return t if PROPERTY has a value specified in PLIST. */ - (plist, prop)) + (plist, property)) { - Lisp_Object val = Fplist_get (plist, prop, Qunbound); - return UNBOUNDP (val) ? Qnil : Qt; + Lisp_Object value = Fplist_get (plist, property, Qunbound); + return UNBOUNDP (value) ? Qnil : Qt; } DEFUN ("check-valid-plist", Fcheck_valid_plist, 1, 1, 0, /* @@ -2352,8 +2355,7 @@ This means that it's a malformed or circular plist. DEFUN ("valid-plist-p", Fvalid_plist_p, 1, 1, 0, /* Given a plist, return non-nil if its format is correct. If it returns nil, `check-valid-plist' will signal an error when given -the plist; that means it's a malformed or circular plist or has non-symbols -as keywords. +the plist; that means it's a malformed or circular plist. */ (plist)) { @@ -2420,60 +2422,60 @@ The new plist is returned. If NIL-MEANS-NOT-PRESENT is given, the DEFUN ("lax-plist-get", Flax_plist_get, 2, 3, 0, /* Extract a value from a lax property list. - -LAX-PLIST is a lax property list, which is a list of the form \(PROP1 -VALUE1 PROP2 VALUE2...), where comparisons between properties is done -using `equal' instead of `eq'. This function returns the value -corresponding to the given PROP, or DEFAULT if PROP is not one of the -properties on the list. +LAX-PLIST is a lax property list, which is a list of the form +\(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between +properties is done using `equal' instead of `eq'. +PROPERTY is usually a symbol. +This function returns the value corresponding to PROPERTY, +or DEFAULT if PROPERTY is not one of the properties on the list. */ - (lax_plist, prop, default_)) + (lax_plist, property, default_)) { - Lisp_Object val = external_plist_get (&lax_plist, prop, 1, ERROR_ME); - if (UNBOUNDP (val)) - return default_; - return val; + Lisp_Object value = external_plist_get (&lax_plist, property, 1, ERROR_ME); + return UNBOUNDP (value) ? default_ : value; } DEFUN ("lax-plist-put", Flax_plist_put, 3, 3, 0, /* -Change value in LAX-PLIST of PROP to VAL. -LAX-PLIST is a lax property list, which is a list of the form \(PROP1 -VALUE1 PROP2 VALUE2...), where comparisons between properties is done -using `equal' instead of `eq'. PROP is usually a symbol and VAL is -any object. If PROP is already a property on the list, its value is -set to VAL, otherwise the new PROP VAL pair is added. The new plist -is returned; use `(setq x (lax-plist-put x prop val))' to be sure to -use the new value. The LAX-PLIST is modified by side effects. -*/ - (lax_plist, prop, val)) -{ - external_plist_put (&lax_plist, prop, val, 1, ERROR_ME); +Change value in LAX-PLIST of PROPERTY to VALUE. +LAX-PLIST is a lax property list, which is a list of the form +\(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between +properties is done using `equal' instead of `eq'. +PROPERTY is usually a symbol and VALUE is any object. +If PROPERTY is already a property on the list, its value is set to +VALUE, otherwise the new PROPERTY VALUE pair is added. +The new plist is returned; use `(setq x (lax-plist-put x property value))' +to be sure to use the new value. LAX-PLIST is modified by side effect. +*/ + (lax_plist, property, value)) +{ + external_plist_put (&lax_plist, property, value, 1, ERROR_ME); return lax_plist; } DEFUN ("lax-plist-remprop", Flax_plist_remprop, 2, 2, 0, /* -Remove from LAX-PLIST the property PROP and its value. -LAX-PLIST is a lax property list, which is a list of the form \(PROP1 -VALUE1 PROP2 VALUE2...), where comparisons between properties is done -using `equal' instead of `eq'. PROP is usually a symbol. The new -plist is returned; use `(setq x (lax-plist-remprop x prop val))' to be -sure to use the new value. The LAX-PLIST is modified by side effects. +Remove from LAX-PLIST the property PROPERTY and its value. +LAX-PLIST is a lax property list, which is a list of the form +\(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between +properties is done using `equal' instead of `eq'. +PROPERTY is usually a symbol. +The new plist is returned; use `(setq x (lax-plist-remprop x property))' +to be sure to use the new value. LAX-PLIST is modified by side effect. */ - (lax_plist, prop)) + (lax_plist, property)) { - external_remprop (&lax_plist, prop, 1, ERROR_ME); + external_remprop (&lax_plist, property, 1, ERROR_ME); return lax_plist; } DEFUN ("lax-plist-member", Flax_plist_member, 2, 2, 0, /* -Return t if PROP has a value specified in LAX-PLIST. -LAX-PLIST is a lax property list, which is a list of the form \(PROP1 -VALUE1 PROP2 VALUE2...), where comparisons between properties is done -using `equal' instead of `eq'. +Return t if PROPERTY has a value specified in LAX-PLIST. +LAX-PLIST is a lax property list, which is a list of the form +\(PROPERTY1 VALUE1 PROPERTY2 VALUE2...), where comparisons between +properties is done using `equal' instead of `eq'. */ - (lax_plist, prop)) + (lax_plist, property)) { - return UNBOUNDP (Flax_plist_get (lax_plist, prop, Qunbound)) ? Qnil : Qt; + return UNBOUNDP (Flax_plist_get (lax_plist, property, Qunbound)) ? Qnil : Qt; } DEFUN ("canonicalize-lax-plist", Fcanonicalize_lax_plist, 1, 2, 0, /* @@ -2552,228 +2554,87 @@ See also `alist-to-plist'. return head; } -/* Symbol plists are directly accessible, so we need to protect against - invalid property list structure */ - -static Lisp_Object -symbol_getprop (Lisp_Object sym, Lisp_Object propname, Lisp_Object default_) -{ - Lisp_Object val = external_plist_get (&XSYMBOL (sym)->plist, propname, - 0, ERROR_ME); - return UNBOUNDP (val) ? default_ : val; -} - -static void -symbol_putprop (Lisp_Object sym, Lisp_Object propname, Lisp_Object value) -{ - external_plist_put (&XSYMBOL (sym)->plist, propname, value, 0, ERROR_ME); -} - -static int -symbol_remprop (Lisp_Object symbol, Lisp_Object propname) -{ - return external_remprop (&XSYMBOL (symbol)->plist, propname, 0, ERROR_ME); -} - -/* We store the string's extent info as the first element of the string's - property list; and the string's MODIFF as the first or second element - of the string's property list (depending on whether the extent info - is present), but only if the string has been modified. This is ugly - but it reduces the memory allocated for the string in the vast - majority of cases, where the string is never modified and has no - extent info. */ - - -static Lisp_Object * -string_plist_ptr (struct Lisp_String *s) -{ - Lisp_Object *ptr = &s->plist; - - if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr))) - ptr = &XCDR (*ptr); - if (CONSP (*ptr) && INTP (XCAR (*ptr))) - ptr = &XCDR (*ptr); - return ptr; -} - -static Lisp_Object -string_getprop (struct Lisp_String *s, Lisp_Object property, - Lisp_Object default_) -{ - Lisp_Object val = external_plist_get (string_plist_ptr (s), property, 0, - ERROR_ME); - return UNBOUNDP (val) ? default_ : val; -} - -static void -string_putprop (struct Lisp_String *s, Lisp_Object property, - Lisp_Object value) -{ - external_plist_put (string_plist_ptr (s), property, value, 0, ERROR_ME); -} - -static int -string_remprop (struct Lisp_String *s, Lisp_Object property) -{ - return external_remprop (string_plist_ptr (s), property, 0, ERROR_ME); -} - -static Lisp_Object -string_plist (struct Lisp_String *s) -{ - return *string_plist_ptr (s); -} - DEFUN ("get", Fget, 2, 3, 0, /* -Return the value of OBJECT's PROPNAME property. -This is the last VALUE stored with `(put OBJECT PROPNAME VALUE)'. +Return the value of OBJECT's PROPERTY property. +This is the last VALUE stored with `(put OBJECT PROPERTY VALUE)'. If there is no such property, return optional third arg DEFAULT -\(which defaults to `nil'). OBJECT can be a symbol, face, extent, -or string. See also `put', `remprop', and `object-plist'. +\(which defaults to `nil'). OBJECT can be a symbol, string, extent, +face, or glyph. See also `put', `remprop', and `object-plist'. */ - (object, propname, default_)) + (object, property, default_)) { /* Various places in emacs call Fget() and expect it not to quit, so don't quit. */ + Lisp_Object val; - /* It's easiest to treat symbols specially because they may not - be an lrecord */ - if (SYMBOLP (object)) - return symbol_getprop (object, propname, default_); - else if (STRINGP (object)) - return string_getprop (XSTRING (object), propname, default_); - else if (LRECORDP (object)) - { - CONST struct lrecord_implementation *imp - = XRECORD_LHEADER_IMPLEMENTATION (object); - if (!imp->getprop) - goto noprops; - - { - Lisp_Object val = (imp->getprop) (object, propname); - if (UNBOUNDP (val)) - val = default_; - return val; - } - } + if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->getprop) + val = XRECORD_LHEADER_IMPLEMENTATION (object)->getprop (object, property); else - { - noprops: - signal_simple_error ("Object type has no properties", object); - return Qnil; /* Not reached */ - } + signal_simple_error ("Object type has no properties", object); + + return UNBOUNDP (val) ? default_ : val; } DEFUN ("put", Fput, 3, 3, 0, /* -Store OBJECT's PROPNAME property with value VALUE. -It can be retrieved with `(get OBJECT PROPNAME)'. OBJECT can be a -symbol, face, extent, or string. - +Set OBJECT's PROPERTY to VALUE. +It can be subsequently retrieved with `(get OBJECT PROPERTY)'. +OBJECT can be a symbol, face, extent, or string. For a string, no properties currently have predefined meanings. For the predefined properties for extents, see `set-extent-property'. For the predefined properties for faces, see `set-face-property'. - See also `get', `remprop', and `object-plist'. */ - (object, propname, value)) + (object, property, value)) { - CHECK_SYMBOL (propname); - CHECK_IMPURE (object); + CHECK_LISP_WRITEABLE (object); - if (SYMBOLP (object)) - symbol_putprop (object, propname, value); - else if (STRINGP (object)) - string_putprop (XSTRING (object), propname, value); - else if (LRECORDP (object)) + if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->putprop) { - CONST struct lrecord_implementation - *imp = XRECORD_LHEADER_IMPLEMENTATION (object); - if (imp->putprop) - { - if (! (imp->putprop) (object, propname, value)) - signal_simple_error ("Can't set property on object", propname); - } - else - goto noprops; + if (! XRECORD_LHEADER_IMPLEMENTATION (object)->putprop + (object, property, value)) + signal_simple_error ("Can't set property on object", property); } else - { - noprops: - signal_simple_error ("Object type has no settable properties", object); - } + signal_simple_error ("Object type has no settable properties", object); return value; } -void -pure_put (Lisp_Object sym, Lisp_Object prop, Lisp_Object val) -{ - Fput (sym, prop, Fpurecopy (val)); -} - DEFUN ("remprop", Fremprop, 2, 2, 0, /* -Remove from OBJECT's property list the property PROPNAME and its -value. OBJECT can be a symbol, face, extent, or string. Returns -non-nil if the property list was actually changed (i.e. if PROPNAME -was present in the property list). See also `get', `put', and -`object-plist'. +Remove, from OBJECT's property list, PROPERTY and its corresponding value. +OBJECT can be a symbol, string, extent, face, or glyph. Return non-nil +if the property list was actually modified (i.e. if PROPERTY was present +in the property list). See also `get', `put', and `object-plist'. */ - (object, propname)) + (object, property)) { - int retval = 0; + int ret = 0; - CHECK_SYMBOL (propname); - CHECK_IMPURE (object); + CHECK_LISP_WRITEABLE (object); - if (SYMBOLP (object)) - retval = symbol_remprop (object, propname); - else if (STRINGP (object)) - retval = string_remprop (XSTRING (object), propname); - else if (LRECORDP (object)) + if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->remprop) { - CONST struct lrecord_implementation - *imp = XRECORD_LHEADER_IMPLEMENTATION (object); - if (imp->remprop) - { - retval = (imp->remprop) (object, propname); - if (retval == -1) - signal_simple_error ("Can't remove property from object", - propname); - } - else - goto noprops; + ret = XRECORD_LHEADER_IMPLEMENTATION (object)->remprop (object, property); + if (ret == -1) + signal_simple_error ("Can't remove property from object", property); } else - { - noprops: - signal_simple_error ("Object type has no removable properties", object); - } + signal_simple_error ("Object type has no removable properties", object); - return retval ? Qt : Qnil; + return ret ? Qt : Qnil; } DEFUN ("object-plist", Fobject_plist, 1, 1, 0, /* -Return a property list of OBJECT's props. -For a symbol this is equivalent to `symbol-plist'. -Do not modify the property list directly; this may or may not have -the desired effects. (In particular, for a property with a special -interpretation, this will probably have no effect at all.) +Return a property list of OBJECT's properties. +For a symbol, this is equivalent to `symbol-plist'. +OBJECT can be a symbol, string, extent, face, or glyph. +Do not modify the returned property list directly; +this may or may not have the desired effects. Use `put' instead. */ (object)) { - if (SYMBOLP (object)) - return Fsymbol_plist (object); - else if (STRINGP (object)) - return string_plist (XSTRING (object)); - else if (LRECORDP (object)) - { - CONST struct lrecord_implementation - *imp = XRECORD_LHEADER_IMPLEMENTATION (object); - if (imp->plist) - return (imp->plist) (object); - else - signal_simple_error ("Object type has no properties", object); - } + if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->plist) + return XRECORD_LHEADER_IMPLEMENTATION (object)->plist (object); else signal_simple_error ("Object type has no properties", object); @@ -2786,50 +2647,15 @@ internal_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { if (depth > 200) error ("Stack overflow in equal"); -#ifndef LRECORD_CONS - do_cdr: -#endif QUIT; if (EQ_WITH_EBOLA_NOTICE (obj1, obj2)) return 1; /* Note that (equal 20 20.0) should be nil */ if (XTYPE (obj1) != XTYPE (obj2)) return 0; -#ifndef LRECORD_CONS - if (CONSP (obj1)) - { - if (!internal_equal (XCAR (obj1), XCAR (obj2), depth + 1)) - return 0; - obj1 = XCDR (obj1); - obj2 = XCDR (obj2); - goto do_cdr; - } -#endif -#ifndef LRECORD_VECTOR - if (VECTORP (obj1)) - { - Lisp_Object *v1 = XVECTOR_DATA (obj1); - Lisp_Object *v2 = XVECTOR_DATA (obj2); - int len = XVECTOR_LENGTH (obj1); - if (len != XVECTOR_LENGTH (obj2)) - return 0; - while (len--) - if (!internal_equal (*v1++, *v2++, depth + 1)) - return 0; - return 1; - } -#endif -#ifndef LRECORD_STRING - if (STRINGP (obj1)) - { - Bytecount len; - return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) && - !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len)); - } -#endif if (LRECORDP (obj1)) { - CONST struct lrecord_implementation + const struct lrecord_implementation *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1), *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2); @@ -2851,39 +2677,12 @@ internal_old_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) { if (depth > 200) error ("Stack overflow in equal"); -#ifndef LRECORD_CONS - do_cdr: -#endif QUIT; if (HACKEQ_UNSAFE (obj1, obj2)) return 1; /* Note that (equal 20 20.0) should be nil */ if (XTYPE (obj1) != XTYPE (obj2)) return 0; -#ifndef LRECORD_CONS - if (CONSP (obj1)) - { - if (!internal_old_equal (XCAR (obj1), XCAR (obj2), depth + 1)) - return 0; - obj1 = XCDR (obj1); - obj2 = XCDR (obj2); - goto do_cdr; - } -#endif -#ifndef LRECORD_VECTOR - if (VECTORP (obj1)) - { - Lisp_Object *v1 = XVECTOR_DATA (obj1); - Lisp_Object *v2 = XVECTOR_DATA (obj2); - int len = XVECTOR_LENGTH (obj1); - if (len != XVECTOR_LENGTH (obj2)) - return 0; - while (len--) - if (!internal_old_equal (*v1++, *v2++, depth + 1)) - return 0; - return 1; - } -#endif return internal_equal (obj1, obj2, depth); } @@ -2895,9 +2694,9 @@ Conses are compared by comparing the cars and the cdrs. Vectors and strings are compared element by element. Numbers are compared by value. Symbols must match exactly. */ - (obj1, obj2)) + (object1, object2)) { - return internal_equal (obj1, obj2, 0) ? Qt : Qnil; + return internal_equal (object1, object2, 0) ? Qt : Qnil; } DEFUN ("old-equal", Fold_equal, 2, 2, 0, /* @@ -2909,14 +2708,14 @@ this is known as the "char-int confoundance disease." See `eq' and This function is provided only for byte-code compatibility with v19. Do not use it. */ - (obj1, obj2)) + (object1, object2)) { - return internal_old_equal (obj1, obj2, 0) ? Qt : Qnil; + return internal_old_equal (object1, object2, 0) ? Qt : Qnil; } DEFUN ("fillarray", Ffillarray, 2, 2, 0, /* -Store each element of ARRAY with ITEM. +Destructively modify ARRAY by replacing each element with ITEM. ARRAY is a vector, bit vector, or string. */ (array, item)) @@ -2924,33 +2723,46 @@ ARRAY is a vector, bit vector, or string. retry: if (STRINGP (array)) { - Emchar charval; - struct Lisp_String *s = XSTRING (array); - Charcount len = string_char_length (s); - Charcount i; + Lisp_String *s = XSTRING (array); + Bytecount old_bytecount = string_length (s); + Bytecount new_bytecount; + Bytecount item_bytecount; + Bufbyte item_buf[MAX_EMCHAR_LEN]; + Bufbyte *p; + Bufbyte *end; + CHECK_CHAR_COERCE_INT (item); - CHECK_IMPURE (array); - charval = XCHAR (item); - for (i = 0; i < len; i++) - set_string_char (s, i, charval); + CHECK_LISP_WRITEABLE (array); + + item_bytecount = set_charptr_emchar (item_buf, XCHAR (item)); + new_bytecount = item_bytecount * string_char_length (s); + + resize_string (s, -1, new_bytecount - old_bytecount); + + for (p = string_data (s), end = p + new_bytecount; + p < end; + p += item_bytecount) + memcpy (p, item_buf, item_bytecount); + *p = '\0'; + bump_string_modiff (array); } else if (VECTORP (array)) { Lisp_Object *p = XVECTOR_DATA (array); - int len = XVECTOR_LENGTH (array); - CHECK_IMPURE (array); + size_t len = XVECTOR_LENGTH (array); + CHECK_LISP_WRITEABLE (array); while (len--) *p++ = item; } else if (BIT_VECTORP (array)) { - struct Lisp_Bit_Vector *v = XBIT_VECTOR (array); - int len = bit_vector_length (v); + Lisp_Bit_Vector *v = XBIT_VECTOR (array); + size_t len = bit_vector_length (v); int bit; CHECK_BIT (item); - CHECK_IMPURE (array); bit = XINT (item); + CHECK_LISP_WRITEABLE (array); while (len--) set_bit_vector_bit (v, len, bit); } @@ -2985,7 +2797,7 @@ bytecode_nconc2 (Lisp_Object *args) { /* (setcdr (last args[0]) args[1]) */ Lisp_Object tortoise, hare; - int count; + size_t count; for (hare = tortoise = args[0], count = 0; CONSP (XCDR (hare)); @@ -3054,7 +2866,7 @@ changing the value of `foo'. if (CONSP (next) || argnum == nargs -1) { /* (setcdr (last val) next) */ - int count; + size_t count; for (count = 0; CONSP (XCDR (last_cons)); @@ -3095,19 +2907,19 @@ changing the value of `foo'. } -/* This is the guts of all mapping functions. - Apply fn to each element of seq, one by one, - storing the results into elements of vals, a C vector of Lisp_Objects. - leni is the length of vals, which should also be the length of seq. +/* This is the guts of several mapping functions. + Apply FUNCTION to each element of SEQUENCE, one by one, + storing the results into elements of VALS, a C vector of Lisp_Objects. + LENI is the length of VALS, which should also be the length of SEQUENCE. If VALS is a null pointer, do not accumulate the results. */ static void -mapcar1 (size_t leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq) +mapcar1 (size_t leni, Lisp_Object *vals, + Lisp_Object function, Lisp_Object sequence) { Lisp_Object result; Lisp_Object args[2]; - int i; struct gcpro gcpro1; if (vals) @@ -3116,21 +2928,63 @@ mapcar1 (size_t leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq) gcpro1.nvars = 0; } - args[0] = fn; + args[0] = function; - if (LISTP (seq)) + if (LISTP (sequence)) { - for (i = 0; i < leni; i++) + /* A devious `function' could either: + - insert garbage into the list in front of us, causing XCDR to crash + - amputate the list behind us using (setcdr), causing the remaining + elts to lose their GCPRO status. + + if (vals != 0) we avoid this by copying the elts into the + `vals' array. By a stroke of luck, `vals' is exactly large + enough to hold the elts left to be traversed as well as the + results computed so far. + + if (vals == 0) we don't have any free space available and + don't want to eat up any more stack with alloca(). + So we use EXTERNAL_LIST_LOOP_3_NO_DECLARE and GCPRO the tail. */ + + if (vals) { - args[1] = XCAR (seq); - seq = XCDR (seq); - result = Ffuncall (2, args); - if (vals) vals[gcpro1.nvars++] = result; + Lisp_Object *val = vals; + size_t i; + + LIST_LOOP_2 (elt, sequence) + *val++ = elt; + + gcpro1.nvars = leni; + + for (i = 0; i < leni; i++) + { + args[1] = vals[i]; + vals[i] = Ffuncall (2, args); + } + } + else + { + Lisp_Object elt, tail; + EMACS_INT len_unused; + struct gcpro ngcpro1; + + NGCPRO1 (tail); + + { + EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, sequence, tail, len_unused) + { + args[1] = elt; + Ffuncall (2, args); + } + } + + NUNGCPRO; } } - else if (VECTORP (seq)) + else if (VECTORP (sequence)) { - Lisp_Object *objs = XVECTOR_DATA (seq); + Lisp_Object *objs = XVECTOR_DATA (sequence); + size_t i; for (i = 0; i < leni; i++) { args[1] = *objs++; @@ -3138,10 +2992,16 @@ mapcar1 (size_t leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq) if (vals) vals[gcpro1.nvars++] = result; } } - else if (STRINGP (seq)) + else if (STRINGP (sequence)) { - Bufbyte *p = XSTRING_DATA (seq); - for (i = 0; i < leni; i++) + /* The string data of `sequence' might be relocated during GC. */ + Bytecount slen = XSTRING_LENGTH (sequence); + Bufbyte *p = alloca_array (Bufbyte, slen); + Bufbyte *end = p + slen; + + memcpy (p, XSTRING_DATA (sequence), slen); + + while (p < end) { args[1] = make_char (charptr_emchar (p)); INC_CHARPTR (p); @@ -3149,9 +3009,10 @@ mapcar1 (size_t leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq) if (vals) vals[gcpro1.nvars++] = result; } } - else if (BIT_VECTORP (seq)) + else if (BIT_VECTORP (sequence)) { - struct Lisp_Bit_Vector *v = XBIT_VECTOR (seq); + Lisp_Bit_Vector *v = XBIT_VECTOR (sequence); + size_t i; for (i = 0; i < leni; i++) { args[1] = make_int (bit_vector_bit (v, i)); @@ -3160,91 +3021,145 @@ mapcar1 (size_t leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq) } } else - abort(); /* cannot get here since Flength(seq) did not get an error */ + ABORT (); /* unreachable, since Flength (sequence) did not get an error */ if (vals) UNGCPRO; } DEFUN ("mapconcat", Fmapconcat, 3, 3, 0, /* -Apply FN to each element of SEQ, and concat the results as strings. -In between each pair of results, stick in SEP. -Thus, " " as SEP results in spaces between the values returned by FN. +Apply FUNCTION to each element of SEQUENCE, and concat the results to a string. +Between each pair of results, insert SEPARATOR. + +Each result, and SEPARATOR, should be strings. Thus, using " " as SEPARATOR +results in spaces between the values returned by FUNCTION. SEQUENCE itself +may be a list, a vector, a bit vector, or a string. */ - (fn, seq, sep)) + (function, sequence, separator)) { - size_t len = XINT (Flength (seq)); + EMACS_INT len = XINT (Flength (sequence)); Lisp_Object *args; - int i; - struct gcpro gcpro1; - int nargs = len + len - 1; + EMACS_INT i; + EMACS_INT nargs = len + len - 1; - if (nargs < 0) return build_string (""); + if (len == 0) return build_string (""); args = alloca_array (Lisp_Object, nargs); - GCPRO1 (sep); - mapcar1 (len, args, fn, seq); - UNGCPRO; + mapcar1 (len, args, function, sequence); for (i = len - 1; i >= 0; i--) args[i + i] = args[i]; for (i = 1; i < nargs; i += 2) - args[i] = sep; + args[i] = separator; return Fconcat (nargs, args); } DEFUN ("mapcar", Fmapcar, 2, 2, 0, /* -Apply FUNCTION to each element of SEQUENCE, and make a list of the results. -The result is a list just as long as SEQUENCE. +Apply FUNCTION to each element of SEQUENCE; return a list of the results. +The result is a list of the same length as SEQUENCE. SEQUENCE may be a list, a vector, a bit vector, or a string. */ - (fn, seq)) + (function, sequence)) { - size_t len = XINT (Flength (seq)); + size_t len = XINT (Flength (sequence)); Lisp_Object *args = alloca_array (Lisp_Object, len); - mapcar1 (len, args, fn, seq); + mapcar1 (len, args, function, sequence); return Flist (len, args); } DEFUN ("mapvector", Fmapvector, 2, 2, 0, /* -Apply FUNCTION to each element of SEQUENCE, making a vector of the results. +Apply FUNCTION to each element of SEQUENCE; return a vector of the results. The result is a vector of the same length as SEQUENCE. -SEQUENCE may be a list, a vector or a string. +SEQUENCE may be a list, a vector, a bit vector, or a string. */ - (fn, seq)) + (function, sequence)) { - size_t len = XINT (Flength (seq)); + size_t len = XINT (Flength (sequence)); Lisp_Object result = make_vector (len, Qnil); struct gcpro gcpro1; GCPRO1 (result); - mapcar1 (len, XVECTOR_DATA (result), fn, seq); + mapcar1 (len, XVECTOR_DATA (result), function, sequence); UNGCPRO; return result; } -DEFUN ("mapc", Fmapc, 2, 2, 0, /* +DEFUN ("mapc-internal", Fmapc_internal, 2, 2, 0, /* Apply FUNCTION to each element of SEQUENCE. SEQUENCE may be a list, a vector, a bit vector, or a string. This function is like `mapcar' but does not accumulate the results, which is more efficient if you do not use the results. + +The difference between this and `mapc' is that `mapc' supports all +the spiffy Common Lisp arguments. You should normally use `mapc'. */ - (fn, seq)) + (function, sequence)) { - mapcar1 (XINT (Flength (seq)), 0, fn, seq); + mapcar1 (XINT (Flength (sequence)), 0, function, sequence); - return seq; + return sequence; +} + + + + +DEFUN ("replace-list", Freplace_list, 2, 2, 0, /* +Destructively replace the list OLD with NEW. +This is like (copy-sequence NEW) except that it reuses the +conses in OLD as much as possible. If OLD and NEW are the same +length, no consing will take place. +*/ + (old, new)) +{ + Lisp_Object tail, oldtail = old, prevoldtail = Qnil; + + EXTERNAL_LIST_LOOP (tail, new) + { + if (!NILP (oldtail)) + { + CHECK_CONS (oldtail); + XCAR (oldtail) = XCAR (tail); + } + else if (!NILP (prevoldtail)) + { + XCDR (prevoldtail) = Fcons (XCAR (tail), Qnil); + prevoldtail = XCDR (prevoldtail); + } + else + old = oldtail = Fcons (XCAR (tail), Qnil); + + if (!NILP (oldtail)) + { + prevoldtail = oldtail; + oldtail = XCDR (oldtail); + } + } + + if (!NILP (prevoldtail)) + XCDR (prevoldtail) = Qnil; + else + old = Qnil; + + return old; } /* #### this function doesn't belong in this file! */ +#ifdef HAVE_GETLOADAVG +#ifdef HAVE_SYS_LOADAVG_H +#include +#endif +#else +int getloadavg (double loadavg[], int nelem); /* Defined in getloadavg.c */ +#endif + DEFUN ("load-average", Fload_average, 0, 1, 0, /* Return list of 1 minute, 5 minute and 15 minute load averages. Each of the three load averages is multiplied by 100, @@ -3314,10 +3229,13 @@ Examples: (featurep '(or (and xemacs 19.15) (and emacs 19.34))) => ; Non-nil on XEmacs 19.15 and later, or FSF Emacs 19.34 and later. + (featurep '(and xemacs 21.02)) + => ; Non-nil on XEmacs 21.2 and later. + NOTE: The advanced arguments of this function (anything other than a symbol) are not yet supported by FSF Emacs. If you feel they are useful for supporting multiple Emacs variants, lobby Richard Stallman at -. +. */ (fexp)) { @@ -3413,7 +3331,7 @@ 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. */ - (feature, file_name)) + (feature, filename)) { Lisp_Object tem; CHECK_SYMBOL (feature); @@ -3429,7 +3347,7 @@ If FILENAME is omitted, the printname of FEATURE is used as the file name. record_unwind_protect (un_autoload, Vautoload_queue); Vautoload_queue = Qt; - call4 (Qload, NILP (file_name) ? Fsymbol_name (feature) : file_name, + call4 (Qload, NILP (filename) ? Fsymbol_name (feature) : filename, Qnil, Qt, Qnil); tem = Fmemq (feature, Vfeatures); @@ -3444,9 +3362,12 @@ If FILENAME is omitted, the printname of FEATURE is used as the file name. } /* base64 encode/decode functions. - Based on code from GNU recode. */ -#define MIME_LINE_LENGTH 76 + Originally based on code from GNU recode. Ported to FSF Emacs by + Lars Magne Ingebrigtsen and Karl Heuer. Ported to XEmacs and + subsequently heavily hacked by Hrvoje Niksic. */ + +#define MIME_LINE_LENGTH 72 #define IS_ASCII(Character) \ ((Character) < 128) @@ -3502,11 +3423,11 @@ static short base64_char_to_value[128] = base64 characters. */ #define ADVANCE_INPUT(c, stream) \ - (ec = Lstream_get_emchar (stream), \ - ec == -1 ? 0 : \ + ((ec = Lstream_get_emchar (stream)) == -1 ? 0 : \ ((ec > 255) ? \ - (error ("Non-ascii character detected in base64 input"), 0) \ - : (c = (Bufbyte)ec, 1))) + (signal_simple_error ("Non-ascii character in base64 input", \ + make_char (ec)), 0) \ + : (c = (Bufbyte)ec), 1)) static Bytind base64_encode_1 (Lstream *istream, Bufbyte *to, int line_break) @@ -3566,105 +3487,90 @@ base64_encode_1 (Lstream *istream, Bufbyte *to, int line_break) } #undef ADVANCE_INPUT -#define ADVANCE_INPUT(c, stream) \ - (ec = Lstream_get_emchar (stream), \ - ec == -1 ? 0 : (c = (Bufbyte)ec, 1)) - -#define INPUT_EOF_P(stream) \ - (ADVANCE_INPUT (c2, stream) \ - ? (Lstream_unget_emchar (stream, (Emchar)c2), 0) \ - : 1) - -#define STORE_BYTE(pos, val) do { \ +/* Get next character from the stream, except that non-base64 + characters are ignored. This is in accordance with rfc2045. EC + should be an Emchar, so that it can hold -1 as the value for EOF. */ +#define ADVANCE_INPUT_IGNORE_NONBASE64(ec, stream, streampos) do { \ + ec = Lstream_get_emchar (stream); \ + ++streampos; \ + /* IS_BASE64 may not be called with negative arguments so check for \ + EOF first. */ \ + if (ec < 0 || IS_BASE64 (ec) || ec == '=') \ + break; \ +} while (1) + +#define STORE_BYTE(pos, val, ccnt) do { \ pos += set_charptr_emchar (pos, (Emchar)((unsigned char)(val))); \ - ++*ccptr; \ + ++ccnt; \ } while (0) static Bytind base64_decode_1 (Lstream *istream, Bufbyte *to, Charcount *ccptr) { - EMACS_INT counter = 0; - Emchar ec; + Charcount ccnt = 0; Bufbyte *e = to; - unsigned long value; + EMACS_INT streampos = 0; - *ccptr = 0; while (1) { - Bufbyte c, c2; - - if (!ADVANCE_INPUT (c, istream)) - break; - - /* Accept wrapping lines, reversibly if at each 76 characters. */ - if (c == '\n') - { - if (!ADVANCE_INPUT (c, istream)) - break; - if (INPUT_EOF_P (istream)) - break; - /* FSF Emacs has this check, apparently inherited from - recode. However, I see no reason to be this picky about - line length -- why reject base64 with say 72-byte lines? - (yes, there are programs that generate them.) */ - /*if (counter != MIME_LINE_LENGTH / 4) return -1;*/ - counter = 1; - } - else - counter++; + Emchar ec; + unsigned long value; /* Process first byte of a quadruplet. */ - if (!IS_BASE64 (c)) - return -1; - value = base64_char_to_value[c] << 18; + ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos); + if (ec < 0) + break; + if (ec == '=') + signal_simple_error ("Illegal `=' character while decoding base64", + make_int (streampos)); + value = base64_char_to_value[ec] << 18; /* Process second byte of a quadruplet. */ - if (!ADVANCE_INPUT (c, istream)) - return -1; - - if (!IS_BASE64 (c)) - return -1; - value |= base64_char_to_value[c] << 12; - - STORE_BYTE (e, value >> 16); + ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos); + if (ec < 0) + error ("Premature EOF while decoding base64"); + if (ec == '=') + signal_simple_error ("Illegal `=' character while decoding base64", + make_int (streampos)); + value |= base64_char_to_value[ec] << 12; + STORE_BYTE (e, value >> 16, ccnt); /* Process third byte of a quadruplet. */ - if (!ADVANCE_INPUT (c, istream)) - return -1; + ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos); + if (ec < 0) + error ("Premature EOF while decoding base64"); - if (c == '=') + if (ec == '=') { - if (!ADVANCE_INPUT (c, istream)) - return -1; - if (c != '=') - return -1; + ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos); + if (ec < 0) + error ("Premature EOF while decoding base64"); + if (ec != '=') + signal_simple_error ("Padding `=' expected but not found while decoding base64", + make_int (streampos)); continue; } - if (!IS_BASE64 (c)) - return -1; - value |= base64_char_to_value[c] << 6; - - STORE_BYTE (e, 0xff & value >> 8); + value |= base64_char_to_value[ec] << 6; + STORE_BYTE (e, 0xff & value >> 8, ccnt); /* Process fourth byte of a quadruplet. */ - if (!ADVANCE_INPUT (c, istream)) - return -1; - - if (c == '=') + ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos); + if (ec < 0) + error ("Premature EOF while decoding base64"); + if (ec == '=') continue; - if (!IS_BASE64 (c)) - return -1; - value |= base64_char_to_value[c]; - - STORE_BYTE (e, 0xff & value); + value |= base64_char_to_value[ec]; + STORE_BYTE (e, 0xff & value, ccnt); } + *ccptr = ccnt; return e - to; } #undef ADVANCE_INPUT -#undef INPUT_EOF_P +#undef ADVANCE_INPUT_IGNORE_NONBASE64 +#undef STORE_BYTE static Lisp_Object free_malloced_ptr (Lisp_Object unwind_obj) @@ -3700,12 +3606,12 @@ free_malloced_ptr (Lisp_Object unwind_obj) } while (0) DEFUN ("base64-encode-region", Fbase64_encode_region, 2, 3, "r", /* -Base64-encode the region between BEG and END. +Base64-encode the region between START and END. Return the length of the encoded text. Optional third argument NO-LINE-BREAK means do not break long lines into shorter lines. */ - (beg, end, no_line_break)) + (start, end, no_line_break)) { Bufbyte *encoded; Bytind encoded_length; @@ -3715,7 +3621,7 @@ into shorter lines. Lisp_Object input; int speccount = specpdl_depth(); - get_buffer_range_char (buf, beg, end, &begv, &zv, 0); + get_buffer_range_char (buf, start, end, &begv, &zv, 0); barf_if_buffer_read_only (buf, begv, zv); /* We need to allocate enough room for encoding the text. @@ -3732,7 +3638,7 @@ into shorter lines. encoded_length = base64_encode_1 (XLSTREAM (input), encoded, NILP (no_line_break)); if (encoded_length > allength) - abort (); + ABORT (); Lstream_delete (XLSTREAM (input)); /* Now we have encoded the region, so we insert the new contents @@ -3741,8 +3647,8 @@ into shorter lines. XMALLOC_UNBIND (encoded, allength, speccount); buffer_delete_range (buf, begv + encoded_length, zv + encoded_length, 0); - /* Simulate FSF Emacs: if point was in the region, place it at the - beginning. */ + /* Simulate FSF Emacs implementation of this function: if point was + in the region, place it at the beginning. */ if (old_pt >= begv && old_pt < zv) BUF_SET_PT (buf, begv); @@ -3752,6 +3658,8 @@ into shorter lines. DEFUN ("base64-encode-string", Fbase64_encode_string, 1, 2, 0, /* Base64 encode STRING and return the result. +Optional argument NO-LINE-BREAK means do not break long lines +into shorter lines. */ (string, no_line_break)) { @@ -3772,7 +3680,7 @@ Base64 encode STRING and return the result. encoded_length = base64_encode_1 (XLSTREAM (input), encoded, NILP (no_line_break)); if (encoded_length > allength) - abort (); + ABORT (); Lstream_delete (XLSTREAM (input)); result = make_string (encoded, encoded_length); XMALLOC_UNBIND (encoded, allength, speccount); @@ -3780,11 +3688,12 @@ Base64 encode STRING and return the result. } DEFUN ("base64-decode-region", Fbase64_decode_region, 2, 2, "r", /* -Base64-decode the region between BEG and END. +Base64-decode the region between START and END. Return the length of the decoded text. If the region can't be decoded, return nil and don't modify the buffer. +Characters out of the base64 alphabet are ignored. */ - (beg, end)) + (start, end)) { struct buffer *buf = current_buffer; Bufpos begv, zv, old_pt = BUF_PT (buf); @@ -3794,7 +3703,7 @@ If the region can't be decoded, return nil and don't modify the buffer. Lisp_Object input; int speccount = specpdl_depth(); - get_buffer_range_char (buf, beg, end, &begv, &zv, 0); + get_buffer_range_char (buf, start, end, &begv, &zv, 0); barf_if_buffer_read_only (buf, begv, zv); length = zv - begv; @@ -3804,16 +3713,9 @@ If the region can't be decoded, return nil and don't modify the buffer. XMALLOC_OR_ALLOCA (decoded, length * MAX_EMCHAR_LEN, Bufbyte); decoded_length = base64_decode_1 (XLSTREAM (input), decoded, &cc_decoded_length); if (decoded_length > length * MAX_EMCHAR_LEN) - abort (); + ABORT (); Lstream_delete (XLSTREAM (input)); - if (decoded_length < 0) - { - /* The decoding wasn't possible. */ - XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount); - return Qnil; - } - /* Now we have decoded the region, so we insert the new contents and delete the old. (Insert first in order to preserve markers.) */ BUF_SET_PT (buf, begv); @@ -3822,8 +3724,8 @@ If the region can't be decoded, return nil and don't modify the buffer. buffer_delete_range (buf, begv + cc_decoded_length, zv + cc_decoded_length, 0); - /* Simulate FSF Emacs: if point was in the region, place it at the - beginning. */ + /* Simulate FSF Emacs implementation of this function: if point was + in the region, place it at the beginning. */ if (old_pt >= begv && old_pt < zv) BUF_SET_PT (buf, begv); @@ -3832,6 +3734,7 @@ If the region can't be decoded, return nil and don't modify the buffer. DEFUN ("base64-decode-string", Fbase64_decode_string, 1, 1, 0, /* Base64-decode STRING and return the result. +Characters out of the base64 alphabet are ignored. */ (string)) { @@ -3851,28 +3754,173 @@ Base64-decode STRING and return the result. decoded_length = base64_decode_1 (XLSTREAM (input), decoded, &cc_decoded_length); if (decoded_length > length * MAX_EMCHAR_LEN) - abort (); + ABORT (); Lstream_delete (XLSTREAM (input)); - if (decoded_length < 0) - { - /* The decoding wasn't possible. */ - XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount); - return Qnil; - } - result = make_string (decoded, decoded_length); XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount); return result; } +Lisp_Object Qideographic_structure; +Lisp_Object Qkeyword_char; + +EXFUN (Fideographic_structure_to_ids, 1); + +Lisp_Object ids_format_unit (Lisp_Object ids_char); +Lisp_Object +ids_format_unit (Lisp_Object ids_char) +{ + if (CHARP (ids_char)) + return Fchar_to_string (ids_char); + else if (INTP (ids_char)) + return Fchar_to_string (Fdecode_char (Qmap_ucs, ids_char, Qnil, Qnil)); + else + { + Lisp_Object ret = Ffind_char (ids_char); + + if (CHARP (ret)) + return Fchar_to_string (ret); + else + { + ret = Fassq (Qideographic_structure, ids_char); + + if (CONSP (ret)) + return Fideographic_structure_to_ids (XCDR (ret)); + } + } + return Qnil; +} + +DEFUN ("ideographic-structure-to-ids", + Fideographic_structure_to_ids, 1, 1, 0, /* +Format ideographic-structure IDS-LIST as an IDS-string. +*/ + (ids_list)) +{ + Lisp_Object dest = Qnil; + + while (CONSP (ids_list)) + { + Lisp_Object cell = XCAR (ids_list); + + if (!NILP (Fchar_ref_p (cell))) + cell = Fplist_get (cell, Qkeyword_char, Qnil); + dest = concat2 (dest, ids_format_unit (cell)); + ids_list = XCDR (ids_list); + } + return dest; +} + +Lisp_Object simplify_char_spec (Lisp_Object char_spec); +Lisp_Object +simplify_char_spec (Lisp_Object char_spec) +{ + if (CHARP (char_spec)) + { + Lisp_Object ccs; + int code_point = ENCODE_CHAR (XCHAR (char_spec), ccs); + + if (code_point >= 0) + { + int cid = decode_defined_char (ccs, code_point, Qnil); + + if (cid >= 0) + return make_char (cid); + } + return char_spec; + } + else if (INTP (char_spec)) + return Fdecode_char (Qmap_ucs, char_spec, Qnil, Qnil); + else + { +#if 0 + Lisp_Object ret = Ffind_char (char_spec); +#else + Lisp_Object ret; + Lisp_Object rest = char_spec; + int have_ccs = 0; + + while (CONSP (rest)) + { + Lisp_Object cell = Fcar (rest); + Lisp_Object ccs; + +#if 0 + if (!LISTP (cell)) + signal_simple_error ("Invalid argument", char_spec); +#endif + if (!NILP (ccs = Ffind_charset (Fcar (cell)))) + { + cell = Fcdr (cell); + if (CONSP (cell)) + ret = Fmake_char (ccs, Fcar (cell), Fcar (Fcdr (cell))); + else + ret = Fdecode_char (ccs, cell, Qt, Qt); + have_ccs = 1; + if (CHARP (ret)) + return ret; + } + rest = Fcdr (rest); + } + if (have_ccs) + ret = Fdefine_char (char_spec); + else + ret = Qnil; +#endif + + if (CHARP (ret)) + return ret; + else + return char_spec; + } +} + +Lisp_Object char_ref_simplify_spec (Lisp_Object char_ref); +Lisp_Object +char_ref_simplify_spec (Lisp_Object char_ref) +{ + if (!NILP (Fchar_ref_p (char_ref))) + { + Lisp_Object ret = Fplist_get (char_ref, Qkeyword_char, Qnil); + + if (NILP (ret)) + return char_ref; + else + return Fplist_put (Fcopy_sequence (char_ref), Qkeyword_char, + simplify_char_spec (ret)); + } + else + return simplify_char_spec (char_ref); +} + +DEFUN ("char-refs-simplify-char-specs", + Fchar_refs_simplify_char_specs, 1, 1, 0, /* +Simplify char-specs in CHAR-REFS. +*/ + (char_refs)) +{ + Lisp_Object rest = char_refs; + + while (CONSP (rest)) + { + Fsetcar (rest, char_ref_simplify_spec (XCAR (rest))); + rest = XCDR (rest); + } + return char_refs; +} + Lisp_Object Qyes_or_no_p; void syms_of_fns (void) { + INIT_LRECORD_IMPLEMENTATION (bit_vector); + defsymbol (&Qstring_lessp, "string-lessp"); defsymbol (&Qidentity, "identity"); + defsymbol (&Qideographic_structure, "ideographic-structure"); + defsymbol (&Qkeyword_char, ":char"); defsymbol (&Qyes_or_no_p, "yes-or-no-p"); DEFSUBR (Fidentity); @@ -3948,8 +3996,9 @@ syms_of_fns (void) DEFSUBR (Fnconc); DEFSUBR (Fmapcar); DEFSUBR (Fmapvector); - DEFSUBR (Fmapc); + DEFSUBR (Fmapc_internal); DEFSUBR (Fmapconcat); + DEFSUBR (Freplace_list); DEFSUBR (Fload_average); DEFSUBR (Ffeaturep); DEFSUBR (Frequire); @@ -3958,6 +4007,8 @@ syms_of_fns (void) DEFSUBR (Fbase64_encode_string); DEFSUBR (Fbase64_decode_region); DEFSUBR (Fbase64_decode_string); + DEFSUBR (Fideographic_structure_to_ids); + DEFSUBR (Fchar_refs_simplify_char_specs); } void @@ -3968,4 +4019,6 @@ A list of symbols which are the features of the executing emacs. Used by `featurep' and `require', and altered by `provide'. */ ); Vfeatures = Qnil; + + Fprovide (intern ("base64")); }