Mercurial > hg > xemacs-beta

comparison src/fns.c @ 398:74fd4e045ea6 r21-2-29

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-29
author cvs
date Mon, 13 Aug 2007 11:13:30 +0200
parents 6719134a07c2
children a86b2b5e0111
comparison
equal deleted inserted replaced
397:f4aeb21a5bad 398:74fd4e045ea6
59 Lisp_Object Qidentity; 59 Lisp_Object Qidentity;
60 60
61 static int internal_old_equal (Lisp_Object, Lisp_Object, int); 61 static int internal_old_equal (Lisp_Object, Lisp_Object, int);
62 62
63 static Lisp_Object 63 static Lisp_Object
64 mark_bit_vector (Lisp_Object obj, void (*markobj) (Lisp_Object)) 64 mark_bit_vector (Lisp_Object obj)
65 { 65 {
66 return Qnil; 66 return Qnil;
67 } 67 }
68 68
69 static void 69 static void
70 print_bit_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) 70 print_bit_vector (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
71 { 71 {
72 int i; 72 size_t i;
73 struct Lisp_Bit_Vector *v = XBIT_VECTOR (obj); 73 Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
74 int len = bit_vector_length (v); 74 size_t len = bit_vector_length (v);
75 int last = len; 75 size_t last = len;
76 76
77 if (INTP (Vprint_length)) 77 if (INTP (Vprint_length))
78 last = min (len, XINT (Vprint_length)); 78 last = min (len, XINT (Vprint_length));
79 write_c_string ("#*", printcharfun); 79 write_c_string ("#*", printcharfun);
80 for (i = 0; i < last; i++) 80 for (i = 0; i < last; i++)
90 } 90 }
91 91
92 static int 92 static int
93 bit_vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) 93 bit_vector_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
94 { 94 {
95 struct Lisp_Bit_Vector *v1 = XBIT_VECTOR (obj1); 95 Lisp_Bit_Vector *v1 = XBIT_VECTOR (obj1);
96 struct Lisp_Bit_Vector *v2 = XBIT_VECTOR (obj2); 96 Lisp_Bit_Vector *v2 = XBIT_VECTOR (obj2);
97 97
98 return ((bit_vector_length (v1) == bit_vector_length (v2)) && 98 return ((bit_vector_length (v1) == bit_vector_length (v2)) &&
99 !memcmp (v1->bits, v2->bits, 99 !memcmp (v1->bits, v2->bits,
100 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v1)) * 100 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v1)) *
101 sizeof (long))); 101 sizeof (long)));
102 } 102 }
103 103
104 static unsigned long 104 static unsigned long
105 bit_vector_hash (Lisp_Object obj, int depth) 105 bit_vector_hash (Lisp_Object obj, int depth)
106 { 106 {
107 struct Lisp_Bit_Vector *v = XBIT_VECTOR (obj); 107 Lisp_Bit_Vector *v = XBIT_VECTOR (obj);
108 return HASH2 (bit_vector_length (v), 108 return HASH2 (bit_vector_length (v),
109 memory_hash (v->bits, 109 memory_hash (v->bits,
110 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v)) * 110 BIT_VECTOR_LONG_STORAGE (bit_vector_length (v)) *
111 sizeof (long))); 111 sizeof (long)));
112 } 112 }
113 113
114 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("bit-vector", bit_vector, 114 static size_t
115 mark_bit_vector, print_bit_vector, 0, 115 size_bit_vector (const void *lheader)
116 bit_vector_equal, bit_vector_hash, 116 {
117 struct Lisp_Bit_Vector); 117 Lisp_Bit_Vector *v = (Lisp_Bit_Vector *) lheader;
118 return offsetof (Lisp_Bit_Vector,
119 bits[BIT_VECTOR_LONG_STORAGE (bit_vector_length (v))]);
120 }
121
122 static const struct lrecord_description bit_vector_description[] = {
123 { XD_LISP_OBJECT, offsetof (Lisp_Bit_Vector, next) },
124 { XD_END }
125 };
126
127
128 DEFINE_BASIC_LRECORD_SEQUENCE_IMPLEMENTATION ("bit-vector", bit_vector,
129 mark_bit_vector, print_bit_vector, 0,
130 bit_vector_equal, bit_vector_hash,
131 bit_vector_description, size_bit_vector,
132 Lisp_Bit_Vector);
118 133
119 DEFUN ("identity", Fidentity, 1, 1, 0, /* 134 DEFUN ("identity", Fidentity, 1, 1, 0, /*
120 Return the argument unchanged. 135 Return the argument unchanged.
121 */ 136 */
122 (arg)) 137 (arg))
175 { 190 {
176 if (!COMPILED_FUNCTIONP (seq)) 191 if (!COMPILED_FUNCTIONP (seq))
177 return XINT (Flength (seq)); 192 return XINT (Flength (seq));
178 else 193 else
179 { 194 {
180 struct Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (seq); 195 Lisp_Compiled_Function *f = XCOMPILED_FUNCTION (seq);
181 196
182 return (f->flags.interactivep ? COMPILED_INTERACTIVE : 197 return (f->flags.interactivep ? COMPILED_INTERACTIVE :
183 f->flags.domainp ? COMPILED_DOMAIN : 198 f->flags.domainp ? COMPILED_DOMAIN :
184 COMPILED_DOC_STRING) 199 COMPILED_DOC_STRING)
185 + 1; 200 + 1;
187 } 202 }
188 203
189 #endif /* LOSING_BYTECODE */ 204 #endif /* LOSING_BYTECODE */
190 205
191 void 206 void
192 check_losing_bytecode (CONST char *function, Lisp_Object seq) 207 check_losing_bytecode (const char *function, Lisp_Object seq)
193 { 208 {
194 if (COMPILED_FUNCTIONP (seq)) 209 if (COMPILED_FUNCTIONP (seq))
195 error_with_frob 210 error_with_frob
196 (seq, 211 (seq,
197 "As of 20.3, `%s' no longer works with compiled-function objects", 212 "As of 20.3, `%s' no longer works with compiled-function objects",
206 retry: 221 retry:
207 if (STRINGP (sequence)) 222 if (STRINGP (sequence))
208 return make_int (XSTRING_CHAR_LENGTH (sequence)); 223 return make_int (XSTRING_CHAR_LENGTH (sequence));
209 else if (CONSP (sequence)) 224 else if (CONSP (sequence))
210 { 225 {
211 int len; 226 size_t len;
212 GET_EXTERNAL_LIST_LENGTH (sequence, len); 227 GET_EXTERNAL_LIST_LENGTH (sequence, len);
213 return make_int (len); 228 return make_int (len);
214 } 229 }
215 else if (VECTORP (sequence)) 230 else if (VECTORP (sequence))
216 return make_int (XVECTOR_LENGTH (sequence)); 231 return make_int (XVECTOR_LENGTH (sequence));
233 which is at least the number of distinct elements. 248 which is at least the number of distinct elements.
234 */ 249 */
235 (list)) 250 (list))
236 { 251 {
237 Lisp_Object hare, tortoise; 252 Lisp_Object hare, tortoise;
238 int len; 253 size_t len;
239 254
240 for (hare = tortoise = list, len = 0; 255 for (hare = tortoise = list, len = 0;
241 CONSP (hare) && (! EQ (hare, tortoise) || len == 0); 256 CONSP (hare) && (! EQ (hare, tortoise) || len == 0);
242 hare = XCDR (hare), len++) 257 hare = XCDR (hare), len++)
243 { 258 {
259 Symbols are also allowed; their print names are used instead. 274 Symbols are also allowed; their print names are used instead.
260 */ 275 */
261 (s1, s2)) 276 (s1, s2))
262 { 277 {
263 Bytecount len; 278 Bytecount len;
264 struct Lisp_String *p1, *p2; 279 Lisp_String *p1, *p2;
265 280
266 if (SYMBOLP (s1)) 281 if (SYMBOLP (s1))
267 p1 = XSYMBOL (s1)->name; 282 p1 = XSYMBOL (s1)->name;
268 else 283 else
269 { 284 {
306 Unicode. When Unicode support is added to XEmacs/Mule, this problem 321 Unicode. When Unicode support is added to XEmacs/Mule, this problem
307 may be solved. 322 may be solved.
308 */ 323 */
309 (s1, s2)) 324 (s1, s2))
310 { 325 {
311 struct Lisp_String *p1, *p2; 326 Lisp_String *p1, *p2;
312 Charcount end, len2; 327 Charcount end, len2;
313 int i; 328 int i;
314 329
315 if (SYMBOLP (s1)) 330 if (SYMBOLP (s1))
316 p1 = XSYMBOL (s1)->name; 331 p1 = XSYMBOL (s1)->name;
337 /* There is no hope of this working under Mule. Even if we converted 352 /* There is no hope of this working under Mule. Even if we converted
338 the data into an external format so that strcoll() processed it 353 the data into an external format so that strcoll() processed it
339 properly, it would still not work because strcoll() does not 354 properly, it would still not work because strcoll() does not
340 handle multiple locales. This is the fundamental flaw in the 355 handle multiple locales. This is the fundamental flaw in the
341 locale model. */ 356 locale model. */
342 Bytecount bcend = charcount_to_bytecount (string_data (p1), end); 357 {
343 /* Compare strings using collation order of locale. */ 358 Bytecount bcend = charcount_to_bytecount (string_data (p1), end);
344 /* Need to be tricky to handle embedded nulls. */ 359 /* Compare strings using collation order of locale. */
345 360 /* Need to be tricky to handle embedded nulls. */
346 for (i = 0; i < bcend; i += strlen((char *) string_data (p1) + i) + 1) 361
347 { 362 for (i = 0; i < bcend; i += strlen((char *) string_data (p1) + i) + 1)
348 int val = strcoll ((char *) string_data (p1) + i, 363 {
349 (char *) string_data (p2) + i); 364 int val = strcoll ((char *) string_data (p1) + i,
350 if (val < 0) 365 (char *) string_data (p2) + i);
351 return Qt; 366 if (val < 0)
352 if (val > 0) 367 return Qt;
353 return Qnil; 368 if (val > 0)
354 } 369 return Qnil;
370 }
371 }
355 #else /* not I18N2, or MULE */ 372 #else /* not I18N2, or MULE */
356 /* #### It is not really necessary to do this: We could compare 373 {
357 byte-by-byte and still get a reasonable comparison, since this 374 Bufbyte *ptr1 = string_data (p1);
358 would compare characters with a charset in the same way. 375 Bufbyte *ptr2 = string_data (p2);
359 With a little rearrangement of the leading bytes, we could 376
360 make most inter-charset comparisons work out the same, too; 377 /* #### It is not really necessary to do this: We could compare
361 even if some don't, this is not a big deal because inter-charset 378 byte-by-byte and still get a reasonable comparison, since this
362 comparisons aren't really well-defined anyway. */ 379 would compare characters with a charset in the same way. With
363 for (i = 0; i < end; i++) 380 a little rearrangement of the leading bytes, we could make most
364 { 381 inter-charset comparisons work out the same, too; even if some
365 if (string_char (p1, i) != string_char (p2, i)) 382 don't, this is not a big deal because inter-charset comparisons
366 return string_char (p1, i) < string_char (p2, i) ? Qt : Qnil; 383 aren't really well-defined anyway. */
367 } 384 for (i = 0; i < end; i++)
385 {
386 if (charptr_emchar (ptr1) != charptr_emchar (ptr2))
387 return charptr_emchar (ptr1) < charptr_emchar (ptr2) ? Qt : Qnil;
388 INC_CHARPTR (ptr1);
389 INC_CHARPTR (ptr2);
390 }
391 }
368 #endif /* not I18N2, or MULE */ 392 #endif /* not I18N2, or MULE */
369 /* Can't do i < len2 because then comparison between "foo" and "foo^@" 393 /* Can't do i < len2 because then comparison between "foo" and "foo^@"
370 won't work right in I18N2 case */ 394 won't work right in I18N2 case */
371 return end < len2 ? Qt : Qnil; 395 return end < len2 ? Qt : Qnil;
372 } 396 }
376 Each string has a tick counter which is incremented each time the contents 400 Each string has a tick counter which is incremented each time the contents
377 of the string are changed (e.g. with `aset'). It wraps around occasionally. 401 of the string are changed (e.g. with `aset'). It wraps around occasionally.
378 */ 402 */
379 (string)) 403 (string))
380 { 404 {
381 struct Lisp_String *s; 405 Lisp_String *s;
382 406
383 CHECK_STRING (string); 407 CHECK_STRING (string);
384 s = XSTRING (string); 408 s = XSTRING (string);
385 if (CONSP (s->plist) && INTP (XCAR (s->plist))) 409 if (CONSP (s->plist) && INTP (XCAR (s->plist)))
386 return XCAR (s->plist); 410 return XCAR (s->plist);
389 } 413 }
390 414
391 void 415 void
392 bump_string_modiff (Lisp_Object str) 416 bump_string_modiff (Lisp_Object str)
393 { 417 {
394 struct Lisp_String *s = XSTRING (str); 418 Lisp_String *s = XSTRING (str);
395 Lisp_Object *ptr = &s->plist; 419 Lisp_Object *ptr = &s->plist;
396 420
397 #ifdef I18N3 421 #ifdef I18N3
398 /* #### remove the `string-translatable' property from the string, 422 /* #### remove the `string-translatable' property from the string,
399 if there is one. */ 423 if there is one. */
504 copy_list (Lisp_Object list) 528 copy_list (Lisp_Object list)
505 { 529 {
506 Lisp_Object list_copy = Fcons (XCAR (list), XCDR (list)); 530 Lisp_Object list_copy = Fcons (XCAR (list), XCDR (list));
507 Lisp_Object last = list_copy; 531 Lisp_Object last = list_copy;
508 Lisp_Object hare, tortoise; 532 Lisp_Object hare, tortoise;
509 int len; 533 size_t len;
510 534
511 for (tortoise = hare = XCDR (list), len = 1; 535 for (tortoise = hare = XCDR (list), len = 1;
512 CONSP (hare); 536 CONSP (hare);
513 hare = XCDR (hare), len++) 537 hare = XCDR (hare), len++)
514 { 538 {
879 Relevant parts of the string-extent-data are copied in the new string. 903 Relevant parts of the string-extent-data are copied in the new string.
880 */ 904 */
881 (string, from, to)) 905 (string, from, to))
882 { 906 {
883 Charcount ccfr, ccto; 907 Charcount ccfr, ccto;
884 Bytecount bfr, bto; 908 Bytecount bfr, blen;
885 Lisp_Object val; 909 Lisp_Object val;
886 910
887 CHECK_STRING (string); 911 CHECK_STRING (string);
888 CHECK_INT (from); 912 CHECK_INT (from);
889 get_string_range_char (string, from, to, &ccfr, &ccto, 913 get_string_range_char (string, from, to, &ccfr, &ccto,
890 GB_HISTORICAL_STRING_BEHAVIOR); 914 GB_HISTORICAL_STRING_BEHAVIOR);
891 bfr = charcount_to_bytecount (XSTRING_DATA (string), ccfr); 915 bfr = charcount_to_bytecount (XSTRING_DATA (string), ccfr);
892 bto = charcount_to_bytecount (XSTRING_DATA (string), ccto); 916 blen = charcount_to_bytecount (XSTRING_DATA (string) + bfr, ccto - ccfr);
893 val = make_string (XSTRING_DATA (string) + bfr, bto - bfr); 917 val = make_string (XSTRING_DATA (string) + bfr, blen);
894 /* Copy any applicable extent information into the new string: */ 918 /* Copy any applicable extent information into the new string: */
895 copy_string_extents (val, string, 0, bfr, bto - bfr); 919 copy_string_extents (val, string, 0, bfr, blen);
896 return val; 920 return val;
897 } 921 }
898 922
899 DEFUN ("subseq", Fsubseq, 2, 3, 0, /* 923 DEFUN ("subseq", Fsubseq, 2, 3, 0, /*
900 Return a subsequence of SEQ, starting at index FROM and ending before TO. 924 Return the subsequence of SEQUENCE starting at START and ending before END.
901 TO may be nil or omitted; then the subsequence runs to the end of SEQ. 925 END may be omitted; then the subsequence runs to the end of SEQUENCE.
902 If FROM or TO is negative, it counts from the end. 926 If START or END is negative, it counts from the end.
903 The resulting subsequence is always the same type as the original 927 The returned subsequence is always of the same type as SEQUENCE.
904 sequence. 928 If SEQUENCE is a string, relevant parts of the string-extent-data
905 If SEQ is a string, relevant parts of the string-extent-data are copied 929 are copied to the new string.
906 to the new string. 930 */
907 */ 931 (sequence, start, end))
908 (seq, from, to)) 932 {
909 { 933 EMACS_INT len, s, e;
910 int len, f, t; 934
911 935 if (STRINGP (sequence))
912 if (STRINGP (seq)) 936 return Fsubstring (sequence, start, end);
913 return Fsubstring (seq, from, to); 937
914 938 len = XINT (Flength (sequence));
915 if (!LISTP (seq) && !VECTORP (seq) && !BIT_VECTORP (seq)) 939
916 { 940 CHECK_INT (start);
917 check_losing_bytecode ("subseq", seq); 941 s = XINT (start);
918 seq = wrong_type_argument (Qsequencep, seq); 942 if (s < 0)
919 } 943 s = len + s;
920 944
921 len = XINT (Flength (seq)); 945 if (NILP (end))
922 946 e = len;
923 CHECK_INT (from);
924 f = XINT (from);
925 if (f < 0)
926 f = len + f;
927
928 if (NILP (to))
929 t = len;
930 else 947 else
931 { 948 {
932 CHECK_INT (to); 949 CHECK_INT (end);
933 t = XINT (to); 950 e = XINT (end);
934 if (t < 0) 951 if (e < 0)
935 t = len + t; 952 e = len + e;
936 } 953 }
937 954
938 if (!(0 <= f && f <= t && t <= len)) 955 if (!(0 <= s && s <= e && e <= len))
939 args_out_of_range_3 (seq, make_int (f), make_int (t)); 956 args_out_of_range_3 (sequence, make_int (s), make_int (e));
940 957
941 if (VECTORP (seq)) 958 if (VECTORP (sequence))
942 { 959 {
943 Lisp_Object result = make_vector (t - f, Qnil); 960 Lisp_Object result = make_vector (e - s, Qnil);
944 int i; 961 EMACS_INT i;
945 Lisp_Object *in_elts = XVECTOR_DATA (seq); 962 Lisp_Object *in_elts = XVECTOR_DATA (sequence);
946 Lisp_Object *out_elts = XVECTOR_DATA (result); 963 Lisp_Object *out_elts = XVECTOR_DATA (result);
947 964
948 for (i = f; i < t; i++) 965 for (i = s; i < e; i++)
949 out_elts[i - f] = in_elts[i]; 966 out_elts[i - s] = in_elts[i];
950 return result; 967 return result;
951 } 968 }
952 969 else if (LISTP (sequence))
953 if (LISTP (seq))
954 { 970 {
955 Lisp_Object result = Qnil; 971 Lisp_Object result = Qnil;
956 int i; 972 EMACS_INT i;
957 973
958 seq = Fnthcdr (make_int (f), seq); 974 sequence = Fnthcdr (make_int (s), sequence);
959 975
960 for (i = f; i < t; i++) 976 for (i = s; i < e; i++)
961 { 977 {
962 result = Fcons (Fcar (seq), result); 978 result = Fcons (Fcar (sequence), result);
963 seq = Fcdr (seq); 979 sequence = Fcdr (sequence);
964 } 980 }
965 981
966 return Fnreverse (result); 982 return Fnreverse (result);
967 } 983 }
968 984 else if (BIT_VECTORP (sequence))
969 /* bit vector */ 985 {
970 { 986 Lisp_Object result = make_bit_vector (e - s, Qzero);
971 Lisp_Object result = make_bit_vector (t - f, Qzero); 987 EMACS_INT i;
972 int i; 988
973 989 for (i = s; i < e; i++)
974 for (i = f; i < t; i++) 990 set_bit_vector_bit (XBIT_VECTOR (result), i - s,
975 set_bit_vector_bit (XBIT_VECTOR (result), i - f, 991 bit_vector_bit (XBIT_VECTOR (sequence), i));
976 bit_vector_bit (XBIT_VECTOR (seq), i)); 992 return result;
977 return result; 993 }
978 } 994 else
995 abort (); /* unreachable, since Flength (sequence) did not get an error */
979 } 996 }
980 997
981 998
982 DEFUN ("nthcdr", Fnthcdr, 2, 2, 0, /* 999 DEFUN ("nthcdr", Fnthcdr, 2, 2, 0, /*
983 Take cdr N times on LIST, and return the result. 1000 Take cdr N times on LIST, and return the result.
984 */ 1001 */
985 (n, list)) 1002 (n, list))
986 { 1003 {
987 REGISTER int i; 1004 REGISTER size_t i;
988 REGISTER Lisp_Object tail = list; 1005 REGISTER Lisp_Object tail = list;
989 CHECK_NATNUM (n); 1006 CHECK_NATNUM (n);
990 for (i = XINT (n); i; i--) 1007 for (i = XINT (n); i; i--)
991 { 1008 {
992 if (CONSP (tail)) 1009 if (CONSP (tail))
1041 BIT_VECTORP (sequence)) 1058 BIT_VECTORP (sequence))
1042 return Faref (sequence, n); 1059 return Faref (sequence, n);
1043 #ifdef LOSING_BYTECODE 1060 #ifdef LOSING_BYTECODE
1044 else if (COMPILED_FUNCTIONP (sequence)) 1061 else if (COMPILED_FUNCTIONP (sequence))
1045 { 1062 {
1046 int idx = XINT (n); 1063 EMACS_INT idx = XINT (n);
1047 if (idx < 0) 1064 if (idx < 0)
1048 { 1065 {
1049 lose: 1066 lose:
1050 args_out_of_range (sequence, n); 1067 args_out_of_range (sequence, n);
1051 } 1068 }
1093 If N is zero, then the atom that terminates the list is returned. 1110 If N is zero, then the atom that terminates the list is returned.
1094 If N is greater than the length of LIST, then LIST itself is returned. 1111 If N is greater than the length of LIST, then LIST itself is returned.
1095 */ 1112 */
1096 (list, n)) 1113 (list, n))
1097 { 1114 {
1098 int int_n, count; 1115 EMACS_INT int_n, count;
1099 Lisp_Object retval, tortoise, hare; 1116 Lisp_Object retval, tortoise, hare;
1100 1117
1101 CHECK_LIST (list); 1118 CHECK_LIST (list);
1102 1119
1103 if (NILP (n)) 1120 if (NILP (n))
1129 Modify LIST to remove the last N (default 1) elements. 1146 Modify LIST to remove the last N (default 1) elements.
1130 If LIST has N or fewer elements, nil is returned and LIST is unmodified. 1147 If LIST has N or fewer elements, nil is returned and LIST is unmodified.
1131 */ 1148 */
1132 (list, n)) 1149 (list, n))
1133 { 1150 {
1134 int int_n; 1151 EMACS_INT int_n;
1135 1152
1136 CHECK_LIST (list); 1153 CHECK_LIST (list);
1137 1154
1138 if (NILP (n)) 1155 if (NILP (n))
1139 int_n = 1; 1156 int_n = 1;
1832 */ 1849 */
1833 int 1850 int
1834 plists_differ (Lisp_Object a, Lisp_Object b, int nil_means_not_present, 1851 plists_differ (Lisp_Object a, Lisp_Object b, int nil_means_not_present,
1835 int laxp, int depth) 1852 int laxp, int depth)
1836 { 1853 {
1837 int eqp = (depth == -1); /* -1 as depth means us eq, not equal. */ 1854 int eqp = (depth == -1); /* -1 as depth means use eq, not equal. */
1838 int la, lb, m, i, fill; 1855 int la, lb, m, i, fill;
1839 Lisp_Object *keys, *vals; 1856 Lisp_Object *keys, *vals;
1840 char *flags; 1857 char *flags;
1841 Lisp_Object rest; 1858 Lisp_Object rest;
1842 1859
1876 if (nil_means_not_present && NILP (v)) continue; 1893 if (nil_means_not_present && NILP (v)) continue;
1877 for (i = 0; i < fill; i++) 1894 for (i = 0; i < fill; i++)
1878 { 1895 {
1879 if (!laxp ? EQ (k, keys [i]) : internal_equal (k, keys [i], depth)) 1896 if (!laxp ? EQ (k, keys [i]) : internal_equal (k, keys [i], depth))
1880 { 1897 {
1881 if ((eqp 1898 if (eqp
1882 /* We narrowly escaped being Ebolified here. */ 1899 /* We narrowly escaped being Ebolified here. */
1883 ? !EQ_WITH_EBOLA_NOTICE (v, vals [i]) 1900 ? !EQ_WITH_EBOLA_NOTICE (v, vals [i])
1884 : !internal_equal (v, vals [i], depth))) 1901 : !internal_equal (v, vals [i], depth))
1885 /* a property in B has a different value than in A */ 1902 /* a property in B has a different value than in A */
1886 goto MISMATCH; 1903 goto MISMATCH;
1887 flags [i] = 1; 1904 flags [i] = 1;
1888 break; 1905 break;
1889 } 1906 }
2350 } 2367 }
2351 2368
2352 DEFUN ("valid-plist-p", Fvalid_plist_p, 1, 1, 0, /* 2369 DEFUN ("valid-plist-p", Fvalid_plist_p, 1, 1, 0, /*
2353 Given a plist, return non-nil if its format is correct. 2370 Given a plist, return non-nil if its format is correct.
2354 If it returns nil, `check-valid-plist' will signal an error when given 2371 If it returns nil, `check-valid-plist' will signal an error when given
2355 the plist; that means it's a malformed or circular plist or has non-symbols 2372 the plist; that means it's a malformed or circular plist.
2356 as keywords.
2357 */ 2373 */
2358 (plist)) 2374 (plist))
2359 { 2375 {
2360 Lisp_Object *tortoise; 2376 Lisp_Object *tortoise;
2361 Lisp_Object *hare; 2377 Lisp_Object *hare;
2428 properties on the list. 2444 properties on the list.
2429 */ 2445 */
2430 (lax_plist, prop, default_)) 2446 (lax_plist, prop, default_))
2431 { 2447 {
2432 Lisp_Object val = external_plist_get (&lax_plist, prop, 1, ERROR_ME); 2448 Lisp_Object val = external_plist_get (&lax_plist, prop, 1, ERROR_ME);
2433 if (UNBOUNDP (val)) 2449 return UNBOUNDP (val) ? default_ : val;
2434 return default_;
2435 return val;
2436 } 2450 }
2437 2451
2438 DEFUN ("lax-plist-put", Flax_plist_put, 3, 3, 0, /* 2452 DEFUN ("lax-plist-put", Flax_plist_put, 3, 3, 0, /*
2439 Change value in LAX-PLIST of PROP to VAL. 2453 Change value in LAX-PLIST of PROP to VAL.
2440 LAX-PLIST is a lax property list, which is a list of the form \(PROP1 2454 LAX-PLIST is a lax property list, which is a list of the form \(PROP1
2550 } 2564 }
2551 2565
2552 return head; 2566 return head;
2553 } 2567 }
2554 2568
2555 /* Symbol plists are directly accessible, so we need to protect against
2556 invalid property list structure */
2557
2558 static Lisp_Object
2559 symbol_getprop (Lisp_Object sym, Lisp_Object propname, Lisp_Object default_)
2560 {
2561 Lisp_Object val = external_plist_get (&XSYMBOL (sym)->plist, propname,
2562 0, ERROR_ME);
2563 return UNBOUNDP (val) ? default_ : val;
2564 }
2565
2566 static void
2567 symbol_putprop (Lisp_Object sym, Lisp_Object propname, Lisp_Object value)
2568 {
2569 external_plist_put (&XSYMBOL (sym)->plist, propname, value, 0, ERROR_ME);
2570 }
2571
2572 static int
2573 symbol_remprop (Lisp_Object symbol, Lisp_Object propname)
2574 {
2575 return external_remprop (&XSYMBOL (symbol)->plist, propname, 0, ERROR_ME);
2576 }
2577
2578 /* We store the string's extent info as the first element of the string's
2579 property list; and the string's MODIFF as the first or second element
2580 of the string's property list (depending on whether the extent info
2581 is present), but only if the string has been modified. This is ugly
2582 but it reduces the memory allocated for the string in the vast
2583 majority of cases, where the string is never modified and has no
2584 extent info. */
2585
2586
2587 static Lisp_Object *
2588 string_plist_ptr (struct Lisp_String *s)
2589 {
2590 Lisp_Object *ptr = &s->plist;
2591
2592 if (CONSP (*ptr) && EXTENT_INFOP (XCAR (*ptr)))
2593 ptr = &XCDR (*ptr);
2594 if (CONSP (*ptr) && INTP (XCAR (*ptr)))
2595 ptr = &XCDR (*ptr);
2596 return ptr;
2597 }
2598
2599 static Lisp_Object
2600 string_getprop (struct Lisp_String *s, Lisp_Object property,
2601 Lisp_Object default_)
2602 {
2603 Lisp_Object val = external_plist_get (string_plist_ptr (s), property, 0,
2604 ERROR_ME);
2605 return UNBOUNDP (val) ? default_ : val;
2606 }
2607
2608 static void
2609 string_putprop (struct Lisp_String *s, Lisp_Object property,
2610 Lisp_Object value)
2611 {
2612 external_plist_put (string_plist_ptr (s), property, value, 0, ERROR_ME);
2613 }
2614
2615 static int
2616 string_remprop (struct Lisp_String *s, Lisp_Object property)
2617 {
2618 return external_remprop (string_plist_ptr (s), property, 0, ERROR_ME);
2619 }
2620
2621 static Lisp_Object
2622 string_plist (struct Lisp_String *s)
2623 {
2624 return *string_plist_ptr (s);
2625 }
2626
2627 DEFUN ("get", Fget, 2, 3, 0, /* 2569 DEFUN ("get", Fget, 2, 3, 0, /*
2628 Return the value of OBJECT's PROPNAME property. 2570 Return the value of OBJECT's PROPERTY property.
2629 This is the last VALUE stored with `(put OBJECT PROPNAME VALUE)'. 2571 This is the last VALUE stored with `(put OBJECT PROPERTY VALUE)'.
2630 If there is no such property, return optional third arg DEFAULT 2572 If there is no such property, return optional third arg DEFAULT
2631 \(which defaults to `nil'). OBJECT can be a symbol, face, extent, 2573 \(which defaults to `nil'). OBJECT can be a symbol, string, extent,
2632 or string. See also `put', `remprop', and `object-plist'. 2574 face, or glyph. See also `put', `remprop', and `object-plist'.
2633 */ 2575 */
2634 (object, propname, default_)) 2576 (object, property, default_))
2635 { 2577 {
2636 /* Various places in emacs call Fget() and expect it not to quit, 2578 /* Various places in emacs call Fget() and expect it not to quit,
2637 so don't quit. */ 2579 so don't quit. */
2638 2580 Lisp_Object val;
2639 /* It's easiest to treat symbols specially because they may not 2581
2640 be an lrecord */ 2582 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->getprop)
2641 if (SYMBOLP (object)) 2583 val = XRECORD_LHEADER_IMPLEMENTATION (object)->getprop (object, property);
2642 return symbol_getprop (object, propname, default_);
2643 else if (STRINGP (object))
2644 return string_getprop (XSTRING (object), propname, default_);
2645 else if (LRECORDP (object))
2646 {
2647 CONST struct lrecord_implementation *imp
2648 = XRECORD_LHEADER_IMPLEMENTATION (object);
2649 if (!imp->getprop)
2650 goto noprops;
2651
2652 {
2653 Lisp_Object val = (imp->getprop) (object, propname);
2654 if (UNBOUNDP (val))
2655 val = default_;
2656 return val;
2657 }
2658 }
2659 else 2584 else
2660 { 2585 signal_simple_error ("Object type has no properties", object);
2661 noprops: 2586
2662 signal_simple_error ("Object type has no properties", object); 2587 return UNBOUNDP (val) ? default_ : val;
2663 return Qnil; /* Not reached */
2664 }
2665 } 2588 }
2666 2589
2667 DEFUN ("put", Fput, 3, 3, 0, /* 2590 DEFUN ("put", Fput, 3, 3, 0, /*
2668 Store OBJECT's PROPNAME property with value VALUE. 2591 Set OBJECT's PROPERTY to VALUE.
2669 It can be retrieved with `(get OBJECT PROPNAME)'. OBJECT can be a 2592 It can be subsequently retrieved with `(get OBJECT PROPERTY)'.
2670 symbol, face, extent, or string. 2593 OBJECT can be a symbol, face, extent, or string.
2671
2672 For a string, no properties currently have predefined meanings. 2594 For a string, no properties currently have predefined meanings.
2673 For the predefined properties for extents, see `set-extent-property'. 2595 For the predefined properties for extents, see `set-extent-property'.
2674 For the predefined properties for faces, see `set-face-property'. 2596 For the predefined properties for faces, see `set-face-property'.
2675
2676 See also `get', `remprop', and `object-plist'. 2597 See also `get', `remprop', and `object-plist'.
2677 */ 2598 */
2678 (object, propname, value)) 2599 (object, property, value))
2679 { 2600 {
2680 CHECK_SYMBOL (propname); 2601 CHECK_LISP_WRITEABLE (object);
2681 CHECK_IMPURE (object); 2602
2682 2603 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->putprop)
2683 if (SYMBOLP (object)) 2604 {
2684 symbol_putprop (object, propname, value); 2605 if (! XRECORD_LHEADER_IMPLEMENTATION (object)->putprop
2685 else if (STRINGP (object)) 2606 (object, property, value))
2686 string_putprop (XSTRING (object), propname, value); 2607 signal_simple_error ("Can't set property on object", property);
2687 else if (LRECORDP (object))
2688 {
2689 CONST struct lrecord_implementation
2690 *imp = XRECORD_LHEADER_IMPLEMENTATION (object);
2691 if (imp->putprop)
2692 {
2693 if (! (imp->putprop) (object, propname, value))
2694 signal_simple_error ("Can't set property on object", propname);
2695 }
2696 else
2697 goto noprops;
2698 } 2608 }
2699 else 2609 else
2700 { 2610 signal_simple_error ("Object type has no settable properties", object);
2701 noprops:
2702 signal_simple_error ("Object type has no settable properties", object);
2703 }
2704 2611
2705 return value; 2612 return value;
2706 } 2613 }
2707 2614
2708 void
2709 pure_put (Lisp_Object sym, Lisp_Object prop, Lisp_Object val)
2710 {
2711 Fput (sym, prop, Fpurecopy (val));
2712 }
2713
2714 DEFUN ("remprop", Fremprop, 2, 2, 0, /* 2615 DEFUN ("remprop", Fremprop, 2, 2, 0, /*
2715 Remove from OBJECT's property list the property PROPNAME and its 2616 Remove, from OBJECT's property list, PROPERTY and its corresponding value.
2716 value. OBJECT can be a symbol, face, extent, or string. Returns 2617 OBJECT can be a symbol, string, extent, face, or glyph. Return non-nil
2717 non-nil if the property list was actually changed (i.e. if PROPNAME 2618 if the property list was actually modified (i.e. if PROPERTY was present
2718 was present in the property list). See also `get', `put', and 2619 in the property list). See also `get', `put', and `object-plist'.
2719 `object-plist'. 2620 */
2720 */ 2621 (object, property))
2721 (object, propname)) 2622 {
2722 { 2623 int ret = 0;
2723 int retval = 0; 2624
2724 2625 CHECK_LISP_WRITEABLE (object);
2725 CHECK_SYMBOL (propname); 2626
2726 CHECK_IMPURE (object); 2627 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->remprop)
2727 2628 {
2728 if (SYMBOLP (object)) 2629 ret = XRECORD_LHEADER_IMPLEMENTATION (object)->remprop (object, property);
2729 retval = symbol_remprop (object, propname); 2630 if (ret == -1)
2730 else if (STRINGP (object)) 2631 signal_simple_error ("Can't remove property from object", property);
2731 retval = string_remprop (XSTRING (object), propname);
2732 else if (LRECORDP (object))
2733 {
2734 CONST struct lrecord_implementation
2735 *imp = XRECORD_LHEADER_IMPLEMENTATION (object);
2736 if (imp->remprop)
2737 {
2738 retval = (imp->remprop) (object, propname);
2739 if (retval == -1)
2740 signal_simple_error ("Can't remove property from object",
2741 propname);
2742 }
2743 else
2744 goto noprops;
2745 } 2632 }
2746 else 2633 else
2747 { 2634 signal_simple_error ("Object type has no removable properties", object);
2748 noprops: 2635
2749 signal_simple_error ("Object type has no removable properties", object); 2636 return ret ? Qt : Qnil;
2750 }
2751
2752 return retval ? Qt : Qnil;
2753 } 2637 }
2754 2638
2755 DEFUN ("object-plist", Fobject_plist, 1, 1, 0, /* 2639 DEFUN ("object-plist", Fobject_plist, 1, 1, 0, /*
2756 Return a property list of OBJECT's props. 2640 Return a property list of OBJECT's properties.
2757 For a symbol this is equivalent to `symbol-plist'. 2641 For a symbol, this is equivalent to `symbol-plist'.
2758 Do not modify the property list directly; this may or may not have 2642 OBJECT can be a symbol, string, extent, face, or glyph.
2759 the desired effects. (In particular, for a property with a special 2643 Do not modify the returned property list directly;
2760 interpretation, this will probably have no effect at all.) 2644 this may or may not have the desired effects. Use `put' instead.
2761 */ 2645 */
2762 (object)) 2646 (object))
2763 { 2647 {
2764 if (SYMBOLP (object)) 2648 if (LRECORDP (object) && XRECORD_LHEADER_IMPLEMENTATION (object)->plist)
2765 return Fsymbol_plist (object); 2649 return XRECORD_LHEADER_IMPLEMENTATION (object)->plist (object);
2766 else if (STRINGP (object))
2767 return string_plist (XSTRING (object));
2768 else if (LRECORDP (object))
2769 {
2770 CONST struct lrecord_implementation
2771 *imp = XRECORD_LHEADER_IMPLEMENTATION (object);
2772 if (imp->plist)
2773 return (imp->plist) (object);
2774 else
2775 signal_simple_error ("Object type has no properties", object);
2776 }
2777 else 2650 else
2778 signal_simple_error ("Object type has no properties", object); 2651 signal_simple_error ("Object type has no properties", object);
2779 2652
2780 return Qnil; 2653 return Qnil;
2781 } 2654 }
2784 int 2657 int
2785 internal_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) 2658 internal_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
2786 { 2659 {
2787 if (depth > 200) 2660 if (depth > 200)
2788 error ("Stack overflow in equal"); 2661 error ("Stack overflow in equal");
2789 #ifndef LRECORD_CONS
2790 do_cdr:
2791 #endif
2792 QUIT; 2662 QUIT;
2793 if (EQ_WITH_EBOLA_NOTICE (obj1, obj2)) 2663 if (EQ_WITH_EBOLA_NOTICE (obj1, obj2))
2794 return 1; 2664 return 1;
2795 /* Note that (equal 20 20.0) should be nil */ 2665 /* Note that (equal 20 20.0) should be nil */
2796 if (XTYPE (obj1) != XTYPE (obj2)) 2666 if (XTYPE (obj1) != XTYPE (obj2))
2797 return 0; 2667 return 0;
2798 #ifndef LRECORD_CONS
2799 if (CONSP (obj1))
2800 {
2801 if (!internal_equal (XCAR (obj1), XCAR (obj2), depth + 1))
2802 return 0;
2803 obj1 = XCDR (obj1);
2804 obj2 = XCDR (obj2);
2805 goto do_cdr;
2806 }
2807 #endif
2808 #ifndef LRECORD_VECTOR
2809 if (VECTORP (obj1))
2810 {
2811 Lisp_Object *v1 = XVECTOR_DATA (obj1);
2812 Lisp_Object *v2 = XVECTOR_DATA (obj2);
2813 int len = XVECTOR_LENGTH (obj1);
2814 if (len != XVECTOR_LENGTH (obj2))
2815 return 0;
2816 while (len--)
2817 if (!internal_equal (*v1++, *v2++, depth + 1))
2818 return 0;
2819 return 1;
2820 }
2821 #endif
2822 #ifndef LRECORD_STRING
2823 if (STRINGP (obj1))
2824 {
2825 Bytecount len;
2826 return (((len = XSTRING_LENGTH (obj1)) == XSTRING_LENGTH (obj2)) &&
2827 !memcmp (XSTRING_DATA (obj1), XSTRING_DATA (obj2), len));
2828 }
2829 #endif
2830 if (LRECORDP (obj1)) 2668 if (LRECORDP (obj1))
2831 { 2669 {
2832 CONST struct lrecord_implementation 2670 const struct lrecord_implementation
2833 *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1), 2671 *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1),
2834 *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2); 2672 *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2);
2835 2673
2836 return (imp1 == imp2) && 2674 return (imp1 == imp2) &&
2837 /* EQ-ness of the objects was noticed above */ 2675 /* EQ-ness of the objects was noticed above */
2849 static int 2687 static int
2850 internal_old_equal (Lisp_Object obj1, Lisp_Object obj2, int depth) 2688 internal_old_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
2851 { 2689 {
2852 if (depth > 200) 2690 if (depth > 200)
2853 error ("Stack overflow in equal"); 2691 error ("Stack overflow in equal");
2854 #ifndef LRECORD_CONS
2855 do_cdr:
2856 #endif
2857 QUIT; 2692 QUIT;
2858 if (HACKEQ_UNSAFE (obj1, obj2)) 2693 if (HACKEQ_UNSAFE (obj1, obj2))
2859 return 1; 2694 return 1;
2860 /* Note that (equal 20 20.0) should be nil */ 2695 /* Note that (equal 20 20.0) should be nil */
2861 if (XTYPE (obj1) != XTYPE (obj2)) 2696 if (XTYPE (obj1) != XTYPE (obj2))
2862 return 0; 2697 return 0;
2863 #ifndef LRECORD_CONS
2864 if (CONSP (obj1))
2865 {
2866 if (!internal_old_equal (XCAR (obj1), XCAR (obj2), depth + 1))
2867 return 0;
2868 obj1 = XCDR (obj1);
2869 obj2 = XCDR (obj2);
2870 goto do_cdr;
2871 }
2872 #endif
2873 #ifndef LRECORD_VECTOR
2874 if (VECTORP (obj1))
2875 {
2876 Lisp_Object *v1 = XVECTOR_DATA (obj1);
2877 Lisp_Object *v2 = XVECTOR_DATA (obj2);
2878 int len = XVECTOR_LENGTH (obj1);
2879 if (len != XVECTOR_LENGTH (obj2))
2880 return 0;
2881 while (len--)
2882 if (!internal_old_equal (*v1++, *v2++, depth + 1))
2883 return 0;
2884 return 1;
2885 }
2886 #endif
2887 2698
2888 return internal_equal (obj1, obj2, depth); 2699 return internal_equal (obj1, obj2, depth);
2889 } 2700 }
2890 2701
2891 DEFUN ("equal", Fequal, 2, 2, 0, /* 2702 DEFUN ("equal", Fequal, 2, 2, 0, /*
2914 return internal_old_equal (obj1, obj2, 0) ? Qt : Qnil; 2725 return internal_old_equal (obj1, obj2, 0) ? Qt : Qnil;
2915 } 2726 }
2916 2727
2917 2728
2918 DEFUN ("fillarray", Ffillarray, 2, 2, 0, /* 2729 DEFUN ("fillarray", Ffillarray, 2, 2, 0, /*
2919 Store each element of ARRAY with ITEM. 2730 Destructively modify ARRAY by replacing each element with ITEM.
2920 ARRAY is a vector, bit vector, or string. 2731 ARRAY is a vector, bit vector, or string.
2921 */ 2732 */
2922 (array, item)) 2733 (array, item))
2923 { 2734 {
2924 retry: 2735 retry:
2925 if (STRINGP (array)) 2736 if (STRINGP (array))
2926 { 2737 {
2927 Emchar charval; 2738 Lisp_String *s = XSTRING (array);
2928 struct Lisp_String *s = XSTRING (array); 2739 Bytecount old_bytecount = string_length (s);
2929 Charcount len = string_char_length (s); 2740 Bytecount new_bytecount;
2930 Charcount i; 2741 Bytecount item_bytecount;
2742 Bufbyte item_buf[MAX_EMCHAR_LEN];
2743 Bufbyte *p;
2744 Bufbyte *end;
2745
2931 CHECK_CHAR_COERCE_INT (item); 2746 CHECK_CHAR_COERCE_INT (item);
2932 CHECK_IMPURE (array); 2747 CHECK_LISP_WRITEABLE (array);
2933 charval = XCHAR (item); 2748
2934 for (i = 0; i < len; i++) 2749 item_bytecount = set_charptr_emchar (item_buf, XCHAR (item));
2935 set_string_char (s, i, charval); 2750 new_bytecount = item_bytecount * string_char_length (s);
2751
2752 resize_string (s, -1, new_bytecount - old_bytecount);
2753
2754 for (p = string_data (s), end = p + new_bytecount;
2755 p < end;
2756 p += item_bytecount)
2757 memcpy (p, item_buf, item_bytecount);
2758 *p = '\0';
2759
2936 bump_string_modiff (array); 2760 bump_string_modiff (array);
2937 } 2761 }
2938 else if (VECTORP (array)) 2762 else if (VECTORP (array))
2939 { 2763 {
2940 Lisp_Object *p = XVECTOR_DATA (array); 2764 Lisp_Object *p = XVECTOR_DATA (array);
2941 int len = XVECTOR_LENGTH (array); 2765 int len = XVECTOR_LENGTH (array);
2942 CHECK_IMPURE (array); 2766 CHECK_LISP_WRITEABLE (array);
2943 while (len--) 2767 while (len--)
2944 *p++ = item; 2768 *p++ = item;
2945 } 2769 }
2946 else if (BIT_VECTORP (array)) 2770 else if (BIT_VECTORP (array))
2947 { 2771 {
2948 struct Lisp_Bit_Vector *v = XBIT_VECTOR (array); 2772 Lisp_Bit_Vector *v = XBIT_VECTOR (array);
2949 int len = bit_vector_length (v); 2773 int len = bit_vector_length (v);
2950 int bit; 2774 int bit;
2951 CHECK_BIT (item); 2775 CHECK_BIT (item);
2952 CHECK_IMPURE (array); 2776 CHECK_LISP_WRITEABLE (array);
2953 bit = XINT (item); 2777 bit = XINT (item);
2954 while (len--) 2778 while (len--)
2955 set_bit_vector_bit (v, len, bit); 2779 set_bit_vector_bit (v, len, bit);
2956 } 2780 }
2957 else 2781 else
3093 } 2917 }
3094 RETURN_UNGCPRO (Qnil); /* No non-nil args provided. */ 2918 RETURN_UNGCPRO (Qnil); /* No non-nil args provided. */
3095 } 2919 }
3096 2920
3097 2921
3098 /* This is the guts of all mapping functions. 2922 /* This is the guts of several mapping functions.
3099 Apply fn to each element of seq, one by one, 2923 Apply FUNCTION to each element of SEQUENCE, one by one,
3100 storing the results into elements of vals, a C vector of Lisp_Objects. 2924 storing the results into elements of VALS, a C vector of Lisp_Objects.
3101 leni is the length of vals, which should also be the length of seq. 2925 LENI is the length of VALS, which should also be the length of SEQUENCE.
3102 2926
3103 If VALS is a null pointer, do not accumulate the results. */ 2927 If VALS is a null pointer, do not accumulate the results. */
3104 2928
3105 static void 2929 static void
3106 mapcar1 (size_t leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq) 2930 mapcar1 (size_t leni, Lisp_Object *vals,
2931 Lisp_Object function, Lisp_Object sequence)
3107 { 2932 {
3108 Lisp_Object result; 2933 Lisp_Object result;
3109 Lisp_Object args[2]; 2934 Lisp_Object args[2];
3110 int i; 2935 int i;
3111 struct gcpro gcpro1; 2936 struct gcpro gcpro1;
3114 { 2939 {
3115 GCPRO1 (vals[0]); 2940 GCPRO1 (vals[0]);
3116 gcpro1.nvars = 0; 2941 gcpro1.nvars = 0;
3117 } 2942 }
3118 2943
3119 args[0] = fn; 2944 args[0] = function;
3120 2945
3121 if (LISTP (seq)) 2946 if (LISTP (sequence))
3122 { 2947 {
3123 for (i = 0; i < leni; i++) 2948 /* A devious `function' could either:
3124 { 2949 - insert garbage into the list in front of us, causing XCDR to crash
3125 args[1] = XCAR (seq); 2950 - amputate the list behind us using (setcdr), causing the remaining
3126 seq = XCDR (seq); 2951 elts to lose their GCPRO status.
3127 result = Ffuncall (2, args); 2952
3128 if (vals) vals[gcpro1.nvars++] = result; 2953 if (vals != 0) we avoid this by copying the elts into the
3129 } 2954 `vals' array. By a stroke of luck, `vals' is exactly large
3130 } 2955 enough to hold the elts left to be traversed as well as the
3131 else if (VECTORP (seq)) 2956 results computed so far.
3132 { 2957
3133 Lisp_Object *objs = XVECTOR_DATA (seq); 2958 if (vals == 0) we don't have any free space available and
2959 don't want to eat up any more stack with alloca().
2960 So we use EXTERNAL_LIST_LOOP_3 and GCPRO the tail. */
2961
2962 if (vals)
2963 {
2964 Lisp_Object *val = vals;
2965 Lisp_Object elt;
2966
2967 LIST_LOOP_2 (elt, sequence)
2968 *val++ = elt;
2969
2970 gcpro1.nvars = leni;
2971
2972 for (i = 0; i < leni; i++)
2973 {
2974 args[1] = vals[i];
2975 vals[i] = Ffuncall (2, args);
2976 }
2977 }
2978 else
2979 {
2980 Lisp_Object elt, tail;
2981 struct gcpro ngcpro1;
2982
2983 NGCPRO1 (tail);
2984
2985 {
2986 EXTERNAL_LIST_LOOP_3 (elt, sequence, tail)
2987 {
2988 args[1] = elt;
2989 Ffuncall (2, args);
2990 }
2991 }
2992
2993 NUNGCPRO;
2994 }
2995 }
2996 else if (VECTORP (sequence))
2997 {
2998 Lisp_Object *objs = XVECTOR_DATA (sequence);
3134 for (i = 0; i < leni; i++) 2999 for (i = 0; i < leni; i++)
3135 { 3000 {
3136 args[1] = *objs++; 3001 args[1] = *objs++;
3137 result = Ffuncall (2, args); 3002 result = Ffuncall (2, args);
3138 if (vals) vals[gcpro1.nvars++] = result; 3003 if (vals) vals[gcpro1.nvars++] = result;
3139 } 3004 }
3140 } 3005 }
3141 else if (STRINGP (seq)) 3006 else if (STRINGP (sequence))
3142 { 3007 {
3143 Bufbyte *p = XSTRING_DATA (seq); 3008 /* The string data of `sequence' might be relocated during GC. */
3144 for (i = 0; i < leni; i++) 3009 Bytecount slen = XSTRING_LENGTH (sequence);
3010 Bufbyte *p = alloca_array (Bufbyte, slen);
3011 Bufbyte *end = p + slen;
3012
3013 memcpy (p, XSTRING_DATA (sequence), slen);
3014
3015 while (p < end)
3145 { 3016 {
3146 args[1] = make_char (charptr_emchar (p)); 3017 args[1] = make_char (charptr_emchar (p));
3147 INC_CHARPTR (p); 3018 INC_CHARPTR (p);
3148 result = Ffuncall (2, args); 3019 result = Ffuncall (2, args);
3149 if (vals) vals[gcpro1.nvars++] = result; 3020 if (vals) vals[gcpro1.nvars++] = result;
3150 } 3021 }
3151 } 3022 }
3152 else if (BIT_VECTORP (seq)) 3023 else if (BIT_VECTORP (sequence))
3153 { 3024 {
3154 struct Lisp_Bit_Vector *v = XBIT_VECTOR (seq); 3025 Lisp_Bit_Vector *v = XBIT_VECTOR (sequence);
3155 for (i = 0; i < leni; i++) 3026 for (i = 0; i < leni; i++)
3156 { 3027 {
3157 args[1] = make_int (bit_vector_bit (v, i)); 3028 args[1] = make_int (bit_vector_bit (v, i));
3158 result = Ffuncall (2, args); 3029 result = Ffuncall (2, args);
3159 if (vals) vals[gcpro1.nvars++] = result; 3030 if (vals) vals[gcpro1.nvars++] = result;
3160 } 3031 }
3161 } 3032 }
3162 else 3033 else
3163 abort(); /* cannot get here since Flength(seq) did not get an error */ 3034 abort (); /* unreachable, since Flength (sequence) did not get an error */
3164 3035
3165 if (vals) 3036 if (vals)
3166 UNGCPRO; 3037 UNGCPRO;
3167 } 3038 }
3168 3039
3169 DEFUN ("mapconcat", Fmapconcat, 3, 3, 0, /* 3040 DEFUN ("mapconcat", Fmapconcat, 3, 3, 0, /*
3170 Apply FN to each element of SEQ, and concat the results as strings. 3041 Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
3171 In between each pair of results, stick in SEP. 3042 In between each pair of results, insert SEPARATOR. Thus, using " " as
3172 Thus, " " as SEP results in spaces between the values returned by FN. 3043 SEPARATOR results in spaces between the values returned by FUNCTION.
3173 */ 3044 SEQUENCE may be a list, a vector, a bit vector, or a string.
3174 (fn, seq, sep)) 3045 */
3175 { 3046 (function, sequence, separator))
3176 size_t len = XINT (Flength (seq)); 3047 {
3048 size_t len = XINT (Flength (sequence));
3177 Lisp_Object *args; 3049 Lisp_Object *args;
3178 int i; 3050 int i;
3179 struct gcpro gcpro1;
3180 int nargs = len + len - 1; 3051 int nargs = len + len - 1;
3181 3052
3182 if (nargs < 0) return build_string (""); 3053 if (len == 0) return build_string ("");
3183 3054
3184 args = alloca_array (Lisp_Object, nargs); 3055 args = alloca_array (Lisp_Object, nargs);
3185 3056
3186 GCPRO1 (sep); 3057 mapcar1 (len, args, function, sequence);
3187 mapcar1 (len, args, fn, seq);
3188 UNGCPRO;
3189 3058
3190 for (i = len - 1; i >= 0; i--) 3059 for (i = len - 1; i >= 0; i--)
3191 args[i + i] = args[i]; 3060 args[i + i] = args[i];
3192 3061
3193 for (i = 1; i < nargs; i += 2) 3062 for (i = 1; i < nargs; i += 2)
3194 args[i] = sep; 3063 args[i] = separator;
3195 3064
3196 return Fconcat (nargs, args); 3065 return Fconcat (nargs, args);
3197 } 3066 }
3198 3067
3199 DEFUN ("mapcar", Fmapcar, 2, 2, 0, /* 3068 DEFUN ("mapcar", Fmapcar, 2, 2, 0, /*
3200 Apply FUNCTION to each element of SEQUENCE, and make a list of the results. 3069 Apply FUNCTION to each element of SEQUENCE; return a list of the results.
3201 The result is a list just as long as SEQUENCE. 3070 The result is a list of the same length as SEQUENCE.
3202 SEQUENCE may be a list, a vector, a bit vector, or a string. 3071 SEQUENCE may be a list, a vector, a bit vector, or a string.
3203 */ 3072 */
3204 (fn, seq)) 3073 (function, sequence))
3205 { 3074 {
3206 size_t len = XINT (Flength (seq)); 3075 size_t len = XINT (Flength (sequence));
3207 Lisp_Object *args = alloca_array (Lisp_Object, len); 3076 Lisp_Object *args = alloca_array (Lisp_Object, len);
3208 3077
3209 mapcar1 (len, args, fn, seq); 3078 mapcar1 (len, args, function, sequence);
3210 3079
3211 return Flist (len, args); 3080 return Flist (len, args);
3212 } 3081 }
3213 3082
3214 DEFUN ("mapvector", Fmapvector, 2, 2, 0, /* 3083 DEFUN ("mapvector", Fmapvector, 2, 2, 0, /*
3215 Apply FUNCTION to each element of SEQUENCE, making a vector of the results. 3084 Apply FUNCTION to each element of SEQUENCE; return a vector of the results.
3216 The result is a vector of the same length as SEQUENCE. 3085 The result is a vector of the same length as SEQUENCE.
3217 SEQUENCE may be a list, a vector or a string. 3086 SEQUENCE may be a list, a vector, a bit vector, or a string.
3218 */ 3087 */
3219 (fn, seq)) 3088 (function, sequence))
3220 { 3089 {
3221 size_t len = XINT (Flength (seq)); 3090 size_t len = XINT (Flength (sequence));
3222 Lisp_Object result = make_vector (len, Qnil); 3091 Lisp_Object result = make_vector (len, Qnil);
3223 struct gcpro gcpro1; 3092 struct gcpro gcpro1;
3224 3093
3225 GCPRO1 (result); 3094 GCPRO1 (result);
3226 mapcar1 (len, XVECTOR_DATA (result), fn, seq); 3095 mapcar1 (len, XVECTOR_DATA (result), function, sequence);
3227 UNGCPRO; 3096 UNGCPRO;
3228 3097
3229 return result; 3098 return result;
3230 } 3099 }
3231 3100
3232 DEFUN ("mapc", Fmapc, 2, 2, 0, /* 3101 DEFUN ("mapc-internal", Fmapc_internal, 2, 2, 0, /*
3233 Apply FUNCTION to each element of SEQUENCE. 3102 Apply FUNCTION to each element of SEQUENCE.
3234 SEQUENCE may be a list, a vector, a bit vector, or a string. 3103 SEQUENCE may be a list, a vector, a bit vector, or a string.
3235 This function is like `mapcar' but does not accumulate the results, 3104 This function is like `mapcar' but does not accumulate the results,
3236 which is more efficient if you do not use the results. 3105 which is more efficient if you do not use the results.
3237 */ 3106
3238 (fn, seq)) 3107 The difference between this and `mapc' is that `mapc' supports all
3239 { 3108 the spiffy Common Lisp arguments. You should normally use `mapc'.
3240 mapcar1 (XINT (Flength (seq)), 0, fn, seq); 3109 */
3241 3110 (function, sequence))
3242 return seq; 3111 {
3112 mapcar1 (XINT (Flength (sequence)), 0, function, sequence);
3113
3114 return sequence;
3243 } 3115 }
3244 3116
3245 3117
3246 /* #### this function doesn't belong in this file! */ 3118 /* #### this function doesn't belong in this file! */
3247 3119
3442 return unbind_to (speccount, feature); 3314 return unbind_to (speccount, feature);
3443 } 3315 }
3444 } 3316 }
3445 3317
3446 /* base64 encode/decode functions. 3318 /* base64 encode/decode functions.
3447 Based on code from GNU recode. */ 3319
3448 3320 Originally based on code from GNU recode. Ported to FSF Emacs by
3449 #define MIME_LINE_LENGTH 76 3321 Lars Magne Ingebrigtsen and Karl Heuer. Ported to XEmacs and
3322 subsequently heavily hacked by Hrvoje Niksic. */
3323
3324 #define MIME_LINE_LENGTH 72
3450 3325
3451 #define IS_ASCII(Character) \ 3326 #define IS_ASCII(Character) \
3452 ((Character) < 128) 3327 ((Character) < 128)
3453 #define IS_BASE64(Character) \ 3328 #define IS_BASE64(Character) \
3454 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0) 3329 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3500 3375
3501 The octets are divided into 6 bit chunks, which are then encoded into 3376 The octets are divided into 6 bit chunks, which are then encoded into
3502 base64 characters. */ 3377 base64 characters. */
3503 3378
3504 #define ADVANCE_INPUT(c, stream) \ 3379 #define ADVANCE_INPUT(c, stream) \
3505 (ec = Lstream_get_emchar (stream), \ 3380 ((ec = Lstream_get_emchar (stream)) == -1 ? 0 : \
3506 ec == -1 ? 0 : \
3507 ((ec > 255) ? \ 3381 ((ec > 255) ? \
3508 (error ("Non-ascii character detected in base64 input"), 0) \ 3382 (signal_simple_error ("Non-ascii character in base64 input", \
3509 : (c = (Bufbyte)ec, 1))) 3383 make_char (ec)), 0) \
3384 : (c = (Bufbyte)ec), 1))
3510 3385
3511 static Bytind 3386 static Bytind
3512 base64_encode_1 (Lstream *istream, Bufbyte *to, int line_break) 3387 base64_encode_1 (Lstream *istream, Bufbyte *to, int line_break)
3513 { 3388 {
3514 EMACS_INT counter = 0; 3389 EMACS_INT counter = 0;
3564 3439
3565 return e - to; 3440 return e - to;
3566 } 3441 }
3567 #undef ADVANCE_INPUT 3442 #undef ADVANCE_INPUT
3568 3443
3569 #define ADVANCE_INPUT(c, stream) \ 3444 /* Get next character from the stream, except that non-base64
3570 (ec = Lstream_get_emchar (stream), \ 3445 characters are ignored. This is in accordance with rfc2045. EC
3571 ec == -1 ? 0 : (c = (Bufbyte)ec, 1)) 3446 should be an Emchar, so that it can hold -1 as the value for EOF. */
3572 3447 #define ADVANCE_INPUT_IGNORE_NONBASE64(ec, stream, streampos) do { \
3573 #define INPUT_EOF_P(stream) \ 3448 ec = Lstream_get_emchar (stream); \
3574 (ADVANCE_INPUT (c2, stream) \ 3449 ++streampos; \
3575 ? (Lstream_unget_emchar (stream, (Emchar)c2), 0) \ 3450 /* IS_BASE64 may not be called with negative arguments so check for \
3576 : 1) 3451 EOF first. */ \
3577 3452 if (ec < 0 || IS_BASE64 (ec) || ec == '=') \
3578 #define STORE_BYTE(pos, val) do { \ 3453 break; \
3454 } while (1)
3455
3456 #define STORE_BYTE(pos, val, ccnt) do { \
3579 pos += set_charptr_emchar (pos, (Emchar)((unsigned char)(val))); \ 3457 pos += set_charptr_emchar (pos, (Emchar)((unsigned char)(val))); \
3580 ++*ccptr; \ 3458 ++ccnt; \
3581 } while (0) 3459 } while (0)
3582 3460
3583 static Bytind 3461 static Bytind
3584 base64_decode_1 (Lstream *istream, Bufbyte *to, Charcount *ccptr) 3462 base64_decode_1 (Lstream *istream, Bufbyte *to, Charcount *ccptr)
3585 { 3463 {
3586 EMACS_INT counter = 0; 3464 Charcount ccnt = 0;
3587 Emchar ec;
3588 Bufbyte *e = to; 3465 Bufbyte *e = to;
3589 unsigned long value; 3466 EMACS_INT streampos = 0;
3590 3467
3591 *ccptr = 0;
3592 while (1) 3468 while (1)
3593 { 3469 {
3594 Bufbyte c, c2; 3470 Emchar ec;
3595 3471 unsigned long value;
3596 if (!ADVANCE_INPUT (c, istream)) 3472
3473 /* Process first byte of a quadruplet. */
3474 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3475 if (ec < 0)
3597 break; 3476 break;
3598 3477 if (ec == '=')
3599 /* Accept wrapping lines, reversibly if at each 76 characters. */ 3478 signal_simple_error ("Illegal `=' character while decoding base64",
3600 if (c == '\n') 3479 make_int (streampos));
3601 { 3480 value = base64_char_to_value[ec] << 18;
3602 if (!ADVANCE_INPUT (c, istream))
3603 break;
3604 if (INPUT_EOF_P (istream))
3605 break;
3606 /* FSF Emacs has this check, apparently inherited from
3607 recode. However, I see no reason to be this picky about
3608 line length -- why reject base64 with say 72-byte lines?
3609 (yes, there are programs that generate them.) */
3610 /*if (counter != MIME_LINE_LENGTH / 4) return -1;*/
3611 counter = 1;
3612 }
3613 else
3614 counter++;
3615
3616 /* Process first byte of a quadruplet. */
3617 if (!IS_BASE64 (c))
3618 return -1;
3619 value = base64_char_to_value[c] << 18;
3620 3481
3621 /* Process second byte of a quadruplet. */ 3482 /* Process second byte of a quadruplet. */
3622 if (!ADVANCE_INPUT (c, istream)) 3483 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3623 return -1; 3484 if (ec < 0)
3624 3485 error ("Premature EOF while decoding base64");
3625 if (!IS_BASE64 (c)) 3486 if (ec == '=')
3626 return -1; 3487 signal_simple_error ("Illegal `=' character while decoding base64",
3627 value |= base64_char_to_value[c] << 12; 3488 make_int (streampos));
3628 3489 value |= base64_char_to_value[ec] << 12;
3629 STORE_BYTE (e, value >> 16); 3490 STORE_BYTE (e, value >> 16, ccnt);
3630 3491
3631 /* Process third byte of a quadruplet. */ 3492 /* Process third byte of a quadruplet. */
3632 if (!ADVANCE_INPUT (c, istream)) 3493 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3633 return -1; 3494 if (ec < 0)
3634 3495 error ("Premature EOF while decoding base64");
3635 if (c == '=') 3496
3636 { 3497 if (ec == '=')
3637 if (!ADVANCE_INPUT (c, istream)) 3498 {
3638 return -1; 3499 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3639 if (c != '=') 3500 if (ec < 0)
3640 return -1; 3501 error ("Premature EOF while decoding base64");
3502 if (ec != '=')
3503 signal_simple_error ("Padding `=' expected but not found while decoding base64",
3504 make_int (streampos));
3641 continue; 3505 continue;
3642 } 3506 }
3643 3507
3644 if (!IS_BASE64 (c)) 3508 value |= base64_char_to_value[ec] << 6;
3645 return -1; 3509 STORE_BYTE (e, 0xff & value >> 8, ccnt);
3646 value |= base64_char_to_value[c] << 6;
3647
3648 STORE_BYTE (e, 0xff & value >> 8);
3649 3510
3650 /* Process fourth byte of a quadruplet. */ 3511 /* Process fourth byte of a quadruplet. */
3651 if (!ADVANCE_INPUT (c, istream)) 3512 ADVANCE_INPUT_IGNORE_NONBASE64 (ec, istream, streampos);
3652 return -1; 3513 if (ec < 0)
3653 3514 error ("Premature EOF while decoding base64");
3654 if (c == '=') 3515 if (ec == '=')
3655 continue; 3516 continue;
3656 3517
3657 if (!IS_BASE64 (c)) 3518 value |= base64_char_to_value[ec];
3658 return -1; 3519 STORE_BYTE (e, 0xff & value, ccnt);
3659 value |= base64_char_to_value[c]; 3520 }
3660 3521
3661 STORE_BYTE (e, 0xff & value); 3522 *ccptr = ccnt;
3662 }
3663
3664 return e - to; 3523 return e - to;
3665 } 3524 }
3666 #undef ADVANCE_INPUT 3525 #undef ADVANCE_INPUT
3667 #undef INPUT_EOF_P 3526 #undef ADVANCE_INPUT_IGNORE_NONBASE64
3527 #undef STORE_BYTE
3668 3528
3669 static Lisp_Object 3529 static Lisp_Object
3670 free_malloced_ptr (Lisp_Object unwind_obj) 3530 free_malloced_ptr (Lisp_Object unwind_obj)
3671 { 3531 {
3672 void *ptr = (void *)get_opaque_ptr (unwind_obj); 3532 void *ptr = (void *)get_opaque_ptr (unwind_obj);
3739 and delete the old. (Insert first in order to preserve markers.) */ 3599 and delete the old. (Insert first in order to preserve markers.) */
3740 buffer_insert_raw_string_1 (buf, begv, encoded, encoded_length, 0); 3600 buffer_insert_raw_string_1 (buf, begv, encoded, encoded_length, 0);
3741 XMALLOC_UNBIND (encoded, allength, speccount); 3601 XMALLOC_UNBIND (encoded, allength, speccount);
3742 buffer_delete_range (buf, begv + encoded_length, zv + encoded_length, 0); 3602 buffer_delete_range (buf, begv + encoded_length, zv + encoded_length, 0);
3743 3603
3744 /* Simulate FSF Emacs: if point was in the region, place it at the 3604 /* Simulate FSF Emacs implementation of this function: if point was
3745 beginning. */ 3605 in the region, place it at the beginning. */
3746 if (old_pt >= begv && old_pt < zv) 3606 if (old_pt >= begv && old_pt < zv)
3747 BUF_SET_PT (buf, begv); 3607 BUF_SET_PT (buf, begv);
3748 3608
3749 /* We return the length of the encoded text. */ 3609 /* We return the length of the encoded text. */
3750 return make_int (encoded_length); 3610 return make_int (encoded_length);
3781 3641
3782 DEFUN ("base64-decode-region", Fbase64_decode_region, 2, 2, "r", /* 3642 DEFUN ("base64-decode-region", Fbase64_decode_region, 2, 2, "r", /*
3783 Base64-decode the region between BEG and END. 3643 Base64-decode the region between BEG and END.
3784 Return the length of the decoded text. 3644 Return the length of the decoded text.
3785 If the region can't be decoded, return nil and don't modify the buffer. 3645 If the region can't be decoded, return nil and don't modify the buffer.
3646 Characters out of the base64 alphabet are ignored.
3786 */ 3647 */
3787 (beg, end)) 3648 (beg, end))
3788 { 3649 {
3789 struct buffer *buf = current_buffer; 3650 struct buffer *buf = current_buffer;
3790 Bufpos begv, zv, old_pt = BUF_PT (buf); 3651 Bufpos begv, zv, old_pt = BUF_PT (buf);
3805 decoded_length = base64_decode_1 (XLSTREAM (input), decoded, &cc_decoded_length); 3666 decoded_length = base64_decode_1 (XLSTREAM (input), decoded, &cc_decoded_length);
3806 if (decoded_length > length * MAX_EMCHAR_LEN) 3667 if (decoded_length > length * MAX_EMCHAR_LEN)
3807 abort (); 3668 abort ();
3808 Lstream_delete (XLSTREAM (input)); 3669 Lstream_delete (XLSTREAM (input));
3809 3670
3810 if (decoded_length < 0)
3811 {
3812 /* The decoding wasn't possible. */
3813 XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
3814 return Qnil;
3815 }
3816
3817 /* Now we have decoded the region, so we insert the new contents 3671 /* Now we have decoded the region, so we insert the new contents
3818 and delete the old. (Insert first in order to preserve markers.) */ 3672 and delete the old. (Insert first in order to preserve markers.) */
3819 BUF_SET_PT (buf, begv); 3673 BUF_SET_PT (buf, begv);
3820 buffer_insert_raw_string_1 (buf, begv, decoded, decoded_length, 0); 3674 buffer_insert_raw_string_1 (buf, begv, decoded, decoded_length, 0);
3821 XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount); 3675 XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
3822 buffer_delete_range (buf, begv + cc_decoded_length, 3676 buffer_delete_range (buf, begv + cc_decoded_length,
3823 zv + cc_decoded_length, 0); 3677 zv + cc_decoded_length, 0);
3824 3678
3825 /* Simulate FSF Emacs: if point was in the region, place it at the 3679 /* Simulate FSF Emacs implementation of this function: if point was
3826 beginning. */ 3680 in the region, place it at the beginning. */
3827 if (old_pt >= begv && old_pt < zv) 3681 if (old_pt >= begv && old_pt < zv)
3828 BUF_SET_PT (buf, begv); 3682 BUF_SET_PT (buf, begv);
3829 3683
3830 return make_int (cc_decoded_length); 3684 return make_int (cc_decoded_length);
3831 } 3685 }
3832 3686
3833 DEFUN ("base64-decode-string", Fbase64_decode_string, 1, 1, 0, /* 3687 DEFUN ("base64-decode-string", Fbase64_decode_string, 1, 1, 0, /*
3834 Base64-decode STRING and return the result. 3688 Base64-decode STRING and return the result.
3689 Characters out of the base64 alphabet are ignored.
3835 */ 3690 */
3836 (string)) 3691 (string))
3837 { 3692 {
3838 Bufbyte *decoded; 3693 Bufbyte *decoded;
3839 Bytind decoded_length; 3694 Bytind decoded_length;
3851 decoded_length = base64_decode_1 (XLSTREAM (input), decoded, 3706 decoded_length = base64_decode_1 (XLSTREAM (input), decoded,
3852 &cc_decoded_length); 3707 &cc_decoded_length);
3853 if (decoded_length > length * MAX_EMCHAR_LEN) 3708 if (decoded_length > length * MAX_EMCHAR_LEN)
3854 abort (); 3709 abort ();
3855 Lstream_delete (XLSTREAM (input)); 3710 Lstream_delete (XLSTREAM (input));
3856
3857 if (decoded_length < 0)
3858 {
3859 /* The decoding wasn't possible. */
3860 XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
3861 return Qnil;
3862 }
3863 3711
3864 result = make_string (decoded, decoded_length); 3712 result = make_string (decoded, decoded_length);
3865 XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount); 3713 XMALLOC_UNBIND (decoded, length * MAX_EMCHAR_LEN, speccount);
3866 return result; 3714 return result;
3867 } 3715 }
3946 DEFSUBR (Fold_equal); 3794 DEFSUBR (Fold_equal);
3947 DEFSUBR (Ffillarray); 3795 DEFSUBR (Ffillarray);
3948 DEFSUBR (Fnconc); 3796 DEFSUBR (Fnconc);
3949 DEFSUBR (Fmapcar); 3797 DEFSUBR (Fmapcar);
3950 DEFSUBR (Fmapvector); 3798 DEFSUBR (Fmapvector);
3951 DEFSUBR (Fmapc); 3799 DEFSUBR (Fmapc_internal);
3952 DEFSUBR (Fmapconcat); 3800 DEFSUBR (Fmapconcat);
3953 DEFSUBR (Fload_average); 3801 DEFSUBR (Fload_average);
3954 DEFSUBR (Ffeaturep); 3802 DEFSUBR (Ffeaturep);
3955 DEFSUBR (Frequire); 3803 DEFSUBR (Frequire);
3956 DEFSUBR (Fprovide); 3804 DEFSUBR (Fprovide);
3966 DEFVAR_LISP ("features", &Vfeatures /* 3814 DEFVAR_LISP ("features", &Vfeatures /*
3967 A list of symbols which are the features of the executing emacs. 3815 A list of symbols which are the features of the executing emacs.
3968 Used by `featurep' and `require', and altered by `provide'. 3816 Used by `featurep' and `require', and altered by `provide'.
3969 */ ); 3817 */ );
3970 Vfeatures = Qnil; 3818 Vfeatures = Qnil;
3971 } 3819
3820 Fprovide (intern ("base64"));
3821 }