X-Git-Url: http://git.chise.org/gitweb/?p=chise%2Fxemacs-chise.git.1;a=blobdiff_plain;f=src%2Ffns.c;h=95ce1459c622b2fa11bf79f44cb934397cc06e4e;hp=c9d19f66b55ab9ab9ac0910c9f9aa3f3641236e8;hb=3198ed8319f99e19a14447745f4f93e4b4522961;hpb=cb9f6f4eadc44f1becb32cbbd1db26449e347755 diff --git a/src/fns.c b/src/fns.c index c9d19f6..95ce145 100644 --- a/src/fns.c +++ b/src/fns.c @@ -36,10 +36,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 +56,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,10 +67,10 @@ 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)); @@ -92,8 +90,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 +102,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. @@ -177,7 +190,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 +202,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 +221,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 +248,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 +271,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 +319,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 +352,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 +400,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 +413,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 +436,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 +528,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,6 +711,7 @@ concat (int nargs, Lisp_Object *args, string_result_ptr = string_result; break; default: + val = Qnil; abort (); } } @@ -841,6 +864,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 +882,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 +898,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; - - if (STRINGP (seq)) - return Fsubstring (seq, from, to); + EMACS_INT len, s, e; - 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 +1013,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 +1072,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 +1124,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 +1160,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 +1195,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 +1230,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 +1246,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 +1260,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 +1276,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 +1287,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 +1296,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 +1311,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 +1326,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 +1349,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 +1369,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 +1382,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 +1462,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 +1476,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 +1490,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 +1504,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 +1515,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 +1556,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 +1677,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 +1699,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 +1744,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 +1835,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 +1879,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 +2077,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 +2276,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 +2354,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 +2421,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 +2553,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 +2646,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 +2676,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 +2693,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 +2707,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 +2722,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 +2796,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 +2865,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 +2906,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 +2927,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 +2991,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 +3008,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 +3020,143 @@ 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 as strings. +In between each pair of results, insert SEPARATOR. Thus, using " " as +SEPARATOR results in spaces between the values returned by FUNCTION. +SEQUENCE 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'. +*/ + (function, sequence)) +{ + mapcar1 (XINT (Flength (sequence)), 0, function, sequence); + + 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. */ - (fn, seq)) + (old, new)) { - mapcar1 (XINT (Flength (seq)), 0, fn, seq); + 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 seq; + 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 +3226,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 +3328,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 +3344,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 +3359,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 +3420,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) @@ -3562,114 +3480,94 @@ base64_encode_1 (Lstream *istream, Bufbyte *to, int line_break) *e++ = base64_value_to_char[0x3f & c]; } - /* Complete last partial line. */ - if (line_break) - if (counter > 0) - *e++ = '\n'; - return e - to; } #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) @@ -3705,12 +3603,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; @@ -3720,7 +3618,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. @@ -3746,8 +3644,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); @@ -3755,10 +3653,12 @@ into shorter lines. return make_int (encoded_length); } -DEFUN ("base64-encode-string", Fbase64_encode_string, 1, 1, 0, /* +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)) + (string, no_line_break)) { Charcount allength, length; Bytind encoded_length; @@ -3769,11 +3669,13 @@ Base64 encode STRING and return the result. CHECK_STRING (string); length = XSTRING_CHAR_LENGTH (string); - allength = length + length/3 + 1 + 6; + allength = length + length/3 + 1; + allength += allength / MIME_LINE_LENGTH + 1 + 6; input = make_lisp_string_input_stream (string, 0, -1); XMALLOC_OR_ALLOCA (encoded, allength, Bufbyte); - encoded_length = base64_encode_1 (XLSTREAM (input), encoded, 0); + encoded_length = base64_encode_1 (XLSTREAM (input), encoded, + NILP (no_line_break)); if (encoded_length > allength) abort (); Lstream_delete (XLSTREAM (input)); @@ -3783,11 +3685,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); @@ -3797,7 +3700,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; @@ -3810,13 +3713,6 @@ If the region can't be decoded, return nil and don't modify the buffer. 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); @@ -3825,8 +3721,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); @@ -3835,6 +3731,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)) { @@ -3857,13 +3754,6 @@ Base64-decode STRING and return the result. 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; @@ -3874,6 +3764,8 @@ 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 (&Qyes_or_no_p, "yes-or-no-p"); @@ -3951,8 +3843,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); @@ -3971,4 +3864,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")); }