Mercurial > hg > xemacs-beta

comparison src/fns.c @ 5125:b5df3737028a ben-lisp-object

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
merge
author Ben Wing <ben@xemacs.org>
date Wed, 24 Feb 2010 01:58:04 -0600
parents 623d57b7fbe8 9624523604c5
children 2a462149bd6a
comparison
equal deleted inserted replaced
5124:623d57b7fbe8 5125:b5df3737028a
1 /* Random utility Lisp functions. 1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 86, 87, 93, 94, 95 Free Software Foundation, Inc. 2 Copyright (C) 1985, 86, 87, 93, 94, 95 Free Software Foundation, Inc.
3 Copyright (C) 1995, 1996, 2000, 2001, 2002, 2003 Ben Wing. 3 Copyright (C) 1995, 1996, 2000, 2001, 2002, 2003, 2010 Ben Wing.
4 4
5 This file is part of XEmacs. 5 This file is part of XEmacs.
6 6
7 XEmacs is free software; you can redistribute it and/or modify it 7 XEmacs is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by the 8 under the terms of the GNU General Public License as published by the
54 /* NOTE: This symbol is also used in lread.c */ 54 /* NOTE: This symbol is also used in lread.c */
55 #define FEATUREP_SYNTAX 55 #define FEATUREP_SYNTAX
56 56
57 Lisp_Object Qstring_lessp; 57 Lisp_Object Qstring_lessp;
58 Lisp_Object Qidentity; 58 Lisp_Object Qidentity;
59 Lisp_Object Qvector, Qarray, Qbit_vector;
59 60
60 Lisp_Object Qbase64_conversion_error; 61 Lisp_Object Qbase64_conversion_error;
61 62
62 Lisp_Object Vpath_separator; 63 Lisp_Object Vpath_separator;
63 64
79 Elemcount len = bit_vector_length (v); 80 Elemcount len = bit_vector_length (v);
80 Elemcount last = len; 81 Elemcount last = len;
81 82
82 if (INTP (Vprint_length)) 83 if (INTP (Vprint_length))
83 last = min (len, XINT (Vprint_length)); 84 last = min (len, XINT (Vprint_length));
84 write_c_string (printcharfun, "#*"); 85 write_ascstring (printcharfun, "#*");
85 for (i = 0; i < last; i++) 86 for (i = 0; i < last; i++)
86 { 87 {
87 if (bit_vector_bit (v, i)) 88 if (bit_vector_bit (v, i))
88 write_c_string (printcharfun, "1"); 89 write_ascstring (printcharfun, "1");
89 else 90 else
90 write_c_string (printcharfun, "0"); 91 write_ascstring (printcharfun, "0");
91 } 92 }
92 93
93 if (last != len) 94 if (last != len)
94 write_c_string (printcharfun, "..."); 95 write_ascstring (printcharfun, "...");
95 } 96 }
96 97
97 static int 98 static int
98 bit_vector_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth)) 99 bit_vector_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth),
100 int UNUSED (foldcase))
99 { 101 {
100 Lisp_Bit_Vector *v1 = XBIT_VECTOR (obj1); 102 Lisp_Bit_Vector *v1 = XBIT_VECTOR (obj1);
101 Lisp_Bit_Vector *v2 = XBIT_VECTOR (obj2); 103 Lisp_Bit_Vector *v2 = XBIT_VECTOR (obj2);
102 104
103 return ((bit_vector_length (v1) == bit_vector_length (v2)) && 105 return ((bit_vector_length (v1) == bit_vector_length (v2)) &&
214 } 216 }
215 217
216 #endif /* LOSING_BYTECODE */ 218 #endif /* LOSING_BYTECODE */
217 219
218 void 220 void
219 check_losing_bytecode (const char *function, Lisp_Object seq) 221 check_losing_bytecode (const Ascbyte *function, Lisp_Object seq)
220 { 222 {
221 if (COMPILED_FUNCTIONP (seq)) 223 if (COMPILED_FUNCTIONP (seq))
222 signal_ferror_with_frob 224 signal_ferror_with_frob
223 (Qinvalid_argument, seq, 225 (Qinvalid_argument, seq,
224 "As of 20.3, `%s' no longer works with compiled-function objects", 226 "As of 20.3, `%s' no longer works with compiled-function objects",
312 314
313 DEFUN ("compare-strings", Fcompare_strings, 6, 7, 0, /* 315 DEFUN ("compare-strings", Fcompare_strings, 6, 7, 0, /*
314 Compare the contents of two strings, maybe ignoring case. 316 Compare the contents of two strings, maybe ignoring case.
315 In string STR1, skip the first START1 characters and stop at END1. 317 In string STR1, skip the first START1 characters and stop at END1.
316 In string STR2, skip the first START2 characters and stop at END2. 318 In string STR2, skip the first START2 characters and stop at END2.
317 END1 and END2 default to the full lengths of the respective strings. 319 END1 and END2 default to the full lengths of the respective strings,
318 320 and arguments that are outside the string (negative STARTi or ENDi
319 Case is significant in this comparison if IGNORE-CASE is nil. 321 greater than length) are coerced to 0 or string length as appropriate.
322
323 Optional IGNORE-CASE non-nil means use case-insensitive comparison.
324 Case is significant by default.
320 325
321 The value is t if the strings (or specified portions) match. 326 The value is t if the strings (or specified portions) match.
322 If string STR1 is less, the value is a negative number N; 327 If string STR1 is less, the value is a negative number N;
323 - 1 - N is the number of characters that match at the beginning. 328 - 1 - N is the number of characters that match at the beginning.
324 If string STR1 is greater, the value is a positive number N; 329 If string STR1 is greater, the value is a positive number N;
332 int res; 337 int res;
333 338
334 CHECK_STRING (str1); 339 CHECK_STRING (str1);
335 CHECK_STRING (str2); 340 CHECK_STRING (str2);
336 get_string_range_char (str1, start1, end1, &ccstart1, &ccend1, 341 get_string_range_char (str1, start1, end1, &ccstart1, &ccend1,
337 GB_HISTORICAL_STRING_BEHAVIOR); 342 GB_HISTORICAL_STRING_BEHAVIOR|GB_COERCE_RANGE);
338 get_string_range_char (str2, start2, end2, &ccstart2, &ccend2, 343 get_string_range_char (str2, start2, end2, &ccstart2, &ccend2,
339 GB_HISTORICAL_STRING_BEHAVIOR); 344 GB_HISTORICAL_STRING_BEHAVIOR|GB_COERCE_RANGE);
340 345
341 bstart1 = string_index_char_to_byte (str1, ccstart1); 346 bstart1 = string_index_char_to_byte (str1, ccstart1);
342 blen1 = string_offset_char_to_byte_len (str1, bstart1, ccend1 - ccstart1); 347 blen1 = string_offset_char_to_byte_len (str1, bstart1, ccend1 - ccstart1);
343 bstart2 = string_index_char_to_byte (str2, ccstart2); 348 bstart2 = string_index_char_to_byte (str2, ccstart2);
344 blen2 = string_offset_char_to_byte_len (str2, bstart2, ccend2 - ccstart2); 349 blen2 = string_offset_char_to_byte_len (str2, bstart2, ccend2 - ccstart2);
975 */ 980 */
976 (sequence, start, end)) 981 (sequence, start, end))
977 { 982 {
978 EMACS_INT len, s, e; 983 EMACS_INT len, s, e;
979 984
985 CHECK_SEQUENCE (sequence);
986
980 if (STRINGP (sequence)) 987 if (STRINGP (sequence))
981 return Fsubstring (sequence, start, end); 988 return Fsubstring (sequence, start, end);
982 989
983 len = XINT (Flength (sequence)); 990 len = XINT (Flength (sequence));
984 991
1036 bit_vector_bit (XBIT_VECTOR (sequence), i)); 1043 bit_vector_bit (XBIT_VECTOR (sequence), i));
1037 return result; 1044 return result;
1038 } 1045 }
1039 else 1046 else
1040 { 1047 {
1041 ABORT (); /* unreachable, since Flength (sequence) did not get 1048 ABORT (); /* unreachable, since CHECK_SEQUENCE (sequence) did not
1042 an error */ 1049 error */
1043 return Qnil; 1050 return Qnil;
1044 } 1051 }
1045 } 1052 }
1046 1053
1047 /* Split STRING into a list of substrings. The substrings are the 1054 /* Split STRING into a list of substrings. The substrings are the
1048 parts of original STRING separated by SEPCHAR. */ 1055 parts of original STRING separated by SEPCHAR.
1056
1057 If UNESCAPE is non-zero, ESCAPECHAR specifies a character that will quote
1058 SEPCHAR, and cause it not to split STRING. A double ESCAPECHAR is
1059 necessary for ESCAPECHAR to appear once in a substring. */
1060
1049 static Lisp_Object 1061 static Lisp_Object
1050 split_string_by_ichar_1 (const Ibyte *string, Bytecount size, 1062 split_string_by_ichar_1 (const Ibyte *string, Bytecount size,
1051 Ichar sepchar) 1063 Ichar sepchar, int unescape, Ichar escapechar)
1052 { 1064 {
1053 Lisp_Object result = Qnil; 1065 Lisp_Object result = Qnil;
1054 const Ibyte *end = string + size; 1066 const Ibyte *end = string + size;
1055 1067
1056 while (1) 1068 if (unescape)
1057 { 1069 {
1058 const Ibyte *p = string; 1070 Ibyte unescape_buffer[64], *unescape_buffer_ptr = unescape_buffer,
1059 while (p < end) 1071 escaped[MAX_ICHAR_LEN], *unescape_cursor;
1060 { 1072 Bytecount unescape_buffer_size = countof (unescape_buffer),
1061 if (itext_ichar (p) == sepchar) 1073 escaped_len = set_itext_ichar (escaped, escapechar);
1062 break; 1074 Boolint deleting_escapes, previous_escaped;
1063 INC_IBYTEPTR (p); 1075 Ichar pchar;
1064 } 1076
1065 result = Fcons (make_string (string, p - string), result); 1077 while (1)
1066 if (p < end) 1078 {
1067 { 1079 const Ibyte *p = string, *cursor;
1068 string = p; 1080 deleting_escapes = 0;
1069 INC_IBYTEPTR (string); /* skip sepchar */ 1081 previous_escaped = 0;
1070 } 1082
1071 else 1083 while (p < end)
1072 break; 1084 {
1085 pchar = itext_ichar (p);
1086
1087 if (pchar == sepchar)
1088 {
1089 if (!previous_escaped)
1090 {
1091 break;
1092 }
1093 }
1094 else if (pchar == escapechar
1095 /* Doubled escapes don't escape: */
1096 && !previous_escaped)
1097 {
1098 ++deleting_escapes;
1099 previous_escaped = 1;
1100 }
1101 else
1102 {
1103 previous_escaped = 0;
1104 }
1105
1106 INC_IBYTEPTR (p);
1107 }
1108
1109 if (deleting_escapes)
1110 {
1111 if (((p - string) - (escaped_len * deleting_escapes))
1112 > unescape_buffer_size)
1113 {
1114 unescape_buffer_size =
1115 ((p - string) - (escaped_len * deleting_escapes)) * 1.5;
1116 unescape_buffer_ptr = alloca_ibytes (unescape_buffer_size);
1117 }
1118
1119 cursor = string;
1120 unescape_cursor = unescape_buffer_ptr;
1121 previous_escaped = 0;
1122
1123 while (cursor < p)
1124 {
1125 pchar = itext_ichar (cursor);
1126
1127 if (pchar != escapechar || previous_escaped)
1128 {
1129 memcpy (unescape_cursor, cursor,
1130 itext_ichar_len (cursor));
1131 INC_IBYTEPTR (unescape_cursor);
1132 }
1133
1134 previous_escaped = !previous_escaped
1135 && (pchar == escapechar);
1136
1137 INC_IBYTEPTR (cursor);
1138 }
1139
1140 result = Fcons (make_string (unescape_buffer_ptr,
1141 unescape_cursor
1142 - unescape_buffer_ptr),
1143 result);
1144 }
1145 else
1146 {
1147 result = Fcons (make_string (string, p - string), result);
1148 }
1149 if (p < end)
1150 {
1151 string = p;
1152 INC_IBYTEPTR (string); /* skip sepchar */
1153 }
1154 else
1155 break;
1156 }
1157 }
1158 else
1159 {
1160 while (1)
1161 {
1162 const Ibyte *p = string;
1163 while (p < end)
1164 {
1165 if (itext_ichar (p) == sepchar)
1166 break;
1167 INC_IBYTEPTR (p);
1168 }
1169 result = Fcons (make_string (string, p - string), result);
1170 if (p < end)
1171 {
1172 string = p;
1173 INC_IBYTEPTR (string); /* skip sepchar */
1174 }
1175 else
1176 break;
1177 }
1073 } 1178 }
1074 return Fnreverse (result); 1179 return Fnreverse (result);
1075 } 1180 }
1076 1181
1077 /* The same as the above, except PATH is an external C string (it is 1182 /* The same as the above, except PATH is an external C string (it is
1092 depend on split_external_path("") returning nil instead of an empty 1197 depend on split_external_path("") returning nil instead of an empty
1093 string? */ 1198 string? */
1094 if (!newlen) 1199 if (!newlen)
1095 return Qnil; 1200 return Qnil;
1096 1201
1097 return split_string_by_ichar_1 (newpath, newlen, SEPCHAR); 1202 return split_string_by_ichar_1 (newpath, newlen, SEPCHAR, 0, 0);
1098 } 1203 }
1099 1204
1100 Lisp_Object 1205 Lisp_Object
1101 split_env_path (const CIbyte *evarname, const Ibyte *default_) 1206 split_env_path (const CIbyte *evarname, const Ibyte *default_)
1102 { 1207 {
1105 path = egetenv (evarname); 1210 path = egetenv (evarname);
1106 if (!path) 1211 if (!path)
1107 path = default_; 1212 path = default_;
1108 if (!path) 1213 if (!path)
1109 return Qnil; 1214 return Qnil;
1110 return split_string_by_ichar_1 (path, qxestrlen (path), SEPCHAR); 1215 return split_string_by_ichar_1 (path, qxestrlen (path), SEPCHAR, 0, 0);
1111 } 1216 }
1112 1217
1113 /* Ben thinks this function should not exist or be exported to Lisp. 1218 /* Ben thinks this function should not exist or be exported to Lisp.
1114 We use it to define split-path-string in subr.el (not!). */ 1219 We use it to define split-path-string in subr.el (not!). */
1115 1220
1116 DEFUN ("split-string-by-char", Fsplit_string_by_char, 2, 2, 0, /* 1221 DEFUN ("split-string-by-char", Fsplit_string_by_char, 2, 3, 0, /*
1117 Split STRING into a list of substrings originally separated by SEPCHAR. 1222 Split STRING into a list of substrings originally separated by SEPCHAR.
1118 */ 1223
1119 (string, sepchar)) 1224 With optional ESCAPE-CHAR, any instances of SEPCHAR preceded by that
1120 { 1225 character will not split the string, and a double instance of ESCAPE-CHAR
1226 will be necessary for a single ESCAPE-CHAR to appear in the output string.
1227 */
1228 (string, sepchar, escape_char))
1229 {
1230 Ichar escape_ichar = 0;
1231
1121 CHECK_STRING (string); 1232 CHECK_STRING (string);
1122 CHECK_CHAR (sepchar); 1233 CHECK_CHAR (sepchar);
1234 if (!NILP (escape_char))
1235 {
1236 CHECK_CHAR (escape_char);
1237 escape_ichar = XCHAR (escape_char);
1238 }
1123 return split_string_by_ichar_1 (XSTRING_DATA (string), 1239 return split_string_by_ichar_1 (XSTRING_DATA (string),
1124 XSTRING_LENGTH (string), 1240 XSTRING_LENGTH (string),
1125 XCHAR (sepchar)); 1241 XCHAR (sepchar),
1242 !NILP (escape_char), escape_ichar);
1126 } 1243 }
1127 1244
1128 /* #### This was supposed to be in subr.el, but is used VERY early in 1245 /* #### This was supposed to be in subr.el, but is used VERY early in
1129 the bootstrap process, so it goes here. Damn. */ 1246 the bootstrap process, so it goes here. Damn. */
1130 1247
1144 "`path-separator' should be set to a single-character string", 1261 "`path-separator' should be set to a single-character string",
1145 Vpath_separator); 1262 Vpath_separator);
1146 1263
1147 return (split_string_by_ichar_1 1264 return (split_string_by_ichar_1
1148 (XSTRING_DATA (path), XSTRING_LENGTH (path), 1265 (XSTRING_DATA (path), XSTRING_LENGTH (path),
1149 itext_ichar (XSTRING_DATA (Vpath_separator)))); 1266 itext_ichar (XSTRING_DATA (Vpath_separator)), 0, 0));
1150 } 1267 }
1151 1268
1152 1269
1153 DEFUN ("nthcdr", Fnthcdr, 2, 2, 0, /* 1270 DEFUN ("nthcdr", Fnthcdr, 2, 2, 0, /*
1154 Take cdr N times on LIST, and return the result. 1271 Take cdr N times on LIST, and return the result.
1976 NIL_MEANS_NOT_PRESENT is as in `plists-eq' etc. 2093 NIL_MEANS_NOT_PRESENT is as in `plists-eq' etc.
1977 LAXP means use `equal' for comparisons. 2094 LAXP means use `equal' for comparisons.
1978 */ 2095 */
1979 int 2096 int
1980 plists_differ (Lisp_Object a, Lisp_Object b, int nil_means_not_present, 2097 plists_differ (Lisp_Object a, Lisp_Object b, int nil_means_not_present,
1981 int laxp, int depth) 2098 int laxp, int depth, int foldcase)
1982 { 2099 {
1983 int eqp = (depth == -1); /* -1 as depth means use eq, not equal. */ 2100 int eqp = (depth == -1); /* -1 as depth means use eq, not equal. */
1984 int la, lb, m, i, fill; 2101 int la, lb, m, i, fill;
1985 Lisp_Object *keys, *vals; 2102 Lisp_Object *keys, *vals;
1986 char *flags; 2103 Boolbyte *flags;
1987 Lisp_Object rest; 2104 Lisp_Object rest;
1988 2105
1989 if (NILP (a) && NILP (b)) 2106 if (NILP (a) && NILP (b))
1990 return 0; 2107 return 0;
1991 2108
1996 lb = XINT (Flength (b)); 2113 lb = XINT (Flength (b));
1997 m = (la > lb ? la : lb); 2114 m = (la > lb ? la : lb);
1998 fill = 0; 2115 fill = 0;
1999 keys = alloca_array (Lisp_Object, m); 2116 keys = alloca_array (Lisp_Object, m);
2000 vals = alloca_array (Lisp_Object, m); 2117 vals = alloca_array (Lisp_Object, m);
2001 flags = alloca_array (char, m); 2118 flags = alloca_array (Boolbyte, m);
2002 2119
2003 /* First extract the pairs from A. */ 2120 /* First extract the pairs from A. */
2004 for (rest = a; !NILP (rest); rest = XCDR (XCDR (rest))) 2121 for (rest = a; !NILP (rest); rest = XCDR (XCDR (rest)))
2005 { 2122 {
2006 Lisp_Object k = XCAR (rest); 2123 Lisp_Object k = XCAR (rest);
2020 Lisp_Object v = XCAR (XCDR (rest)); 2137 Lisp_Object v = XCAR (XCDR (rest));
2021 /* Maybe be Ebolified. */ 2138 /* Maybe be Ebolified. */
2022 if (nil_means_not_present && NILP (v)) continue; 2139 if (nil_means_not_present && NILP (v)) continue;
2023 for (i = 0; i < fill; i++) 2140 for (i = 0; i < fill; i++)
2024 { 2141 {
2025 if (!laxp ? EQ (k, keys [i]) : internal_equal (k, keys [i], depth)) 2142 if (!laxp ? EQ (k, keys [i]) :
2143 internal_equal_0 (k, keys [i], depth, foldcase))
2026 { 2144 {
2027 if (eqp 2145 if (eqp
2028 /* We narrowly escaped being Ebolified here. */ 2146 /* We narrowly escaped being Ebolified here. */
2029 ? !EQ_WITH_EBOLA_NOTICE (v, vals [i]) 2147 ? !EQ_WITH_EBOLA_NOTICE (v, vals [i])
2030 : !internal_equal (v, vals [i], depth)) 2148 : !internal_equal_0 (v, vals [i], depth, foldcase))
2031 /* a property in B has a different value than in A */ 2149 /* a property in B has a different value than in A */
2032 goto MISMATCH; 2150 goto MISMATCH;
2033 flags [i] = 1; 2151 flags [i] = 1;
2034 break; 2152 break;
2035 } 2153 }
2061 old Lisp implementations, but should not be used except for backward 2179 old Lisp implementations, but should not be used except for backward
2062 compatibility. 2180 compatibility.
2063 */ 2181 */
2064 (a, b, nil_means_not_present)) 2182 (a, b, nil_means_not_present))
2065 { 2183 {
2066 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, -1) 2184 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, -1, 0)
2067 ? Qnil : Qt); 2185 ? Qnil : Qt);
2068 } 2186 }
2069 2187
2070 DEFUN ("plists-equal", Fplists_equal, 2, 3, 0, /* 2188 DEFUN ("plists-equal", Fplists_equal, 2, 3, 0, /*
2071 Return non-nil if property lists A and B are `equal'. 2189 Return non-nil if property lists A and B are `equal'.
2078 old Lisp implementations, but should not be used except for backward 2196 old Lisp implementations, but should not be used except for backward
2079 compatibility. 2197 compatibility.
2080 */ 2198 */
2081 (a, b, nil_means_not_present)) 2199 (a, b, nil_means_not_present))
2082 { 2200 {
2083 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, 1) 2201 return (plists_differ (a, b, !NILP (nil_means_not_present), 0, 1, 0)
2084 ? Qnil : Qt); 2202 ? Qnil : Qt);
2085 } 2203 }
2086 2204
2087 2205
2088 DEFUN ("lax-plists-eq", Flax_plists_eq, 2, 3, 0, /* 2206 DEFUN ("lax-plists-eq", Flax_plists_eq, 2, 3, 0, /*
2098 old Lisp implementations, but should not be used except for backward 2216 old Lisp implementations, but should not be used except for backward
2099 compatibility. 2217 compatibility.
2100 */ 2218 */
2101 (a, b, nil_means_not_present)) 2219 (a, b, nil_means_not_present))
2102 { 2220 {
2103 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, -1) 2221 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, -1, 0)
2104 ? Qnil : Qt); 2222 ? Qnil : Qt);
2105 } 2223 }
2106 2224
2107 DEFUN ("lax-plists-equal", Flax_plists_equal, 2, 3, 0, /* 2225 DEFUN ("lax-plists-equal", Flax_plists_equal, 2, 3, 0, /*
2108 Return non-nil if lax property lists A and B are `equal'. 2226 Return non-nil if lax property lists A and B are `equal'.
2117 old Lisp implementations, but should not be used except for backward 2235 old Lisp implementations, but should not be used except for backward
2118 compatibility. 2236 compatibility.
2119 */ 2237 */
2120 (a, b, nil_means_not_present)) 2238 (a, b, nil_means_not_present))
2121 { 2239 {
2122 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, 1) 2240 return (plists_differ (a, b, !NILP (nil_means_not_present), 1, 1, 0)
2123 ? Qnil : Qt); 2241 ? Qnil : Qt);
2124 } 2242 }
2125 2243
2126 /* Return the value associated with key PROPERTY in property list PLIST. 2244 /* Return the value associated with key PROPERTY in property list PLIST.
2127 Return nil if key not found. This function is used for internal 2245 Return nil if key not found. This function is used for internal
2802 return make_int (internal_equal (obj1, obj2, XINT (depth))); 2920 return make_int (internal_equal (obj1, obj2, XINT (depth)));
2803 } 2921 }
2804 2922
2805 int 2923 int
2806 internal_equal_trapping_problems (Lisp_Object warning_class, 2924 internal_equal_trapping_problems (Lisp_Object warning_class,
2807 const char *warning_string, 2925 const Ascbyte *warning_string,
2808 int flags, 2926 int flags,
2809 struct call_trapping_problems_result *p, 2927 struct call_trapping_problems_result *p,
2810 int retval, 2928 int retval,
2811 Lisp_Object obj1, Lisp_Object obj2, 2929 Lisp_Object obj1, Lisp_Object obj2,
2812 int depth) 2930 int depth)
2839 *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1), 2957 *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1),
2840 *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2); 2958 *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2);
2841 2959
2842 return (imp1 == imp2) && 2960 return (imp1 == imp2) &&
2843 /* EQ-ness of the objects was noticed above */ 2961 /* EQ-ness of the objects was noticed above */
2844 (imp1->equal && (imp1->equal) (obj1, obj2, depth)); 2962 (imp1->equal && (imp1->equal) (obj1, obj2, depth, 0));
2845 } 2963 }
2846 2964
2847 return 0; 2965 return 0;
2966 }
2967
2968 enum array_type
2969 {
2970 ARRAY_NONE = 0,
2971 ARRAY_STRING,
2972 ARRAY_VECTOR,
2973 ARRAY_BIT_VECTOR
2974 };
2975
2976 static enum array_type
2977 array_type (Lisp_Object obj)
2978 {
2979 if (STRINGP (obj))
2980 return ARRAY_STRING;
2981 if (VECTORP (obj))
2982 return ARRAY_VECTOR;
2983 if (BIT_VECTORP (obj))
2984 return ARRAY_BIT_VECTOR;
2985 return ARRAY_NONE;
2848 } 2986 }
2849 2987
2850 int 2988 int
2851 internal_equalp (Lisp_Object obj1, Lisp_Object obj2, int depth) 2989 internal_equalp (Lisp_Object obj1, Lisp_Object obj2, int depth)
2852 { 2990 {
2853 if (depth > 200) 2991 if (depth > 200)
2854 stack_overflow ("Stack overflow in equalp", Qunbound); 2992 stack_overflow ("Stack overflow in equalp", Qunbound);
2855 QUIT; 2993 QUIT;
2994
2995 /* 1. Objects that are `eq' are equal. This will catch the common case
2996 of two equal fixnums or the same object seen twice. */
2856 if (EQ_WITH_EBOLA_NOTICE (obj1, obj2)) 2997 if (EQ_WITH_EBOLA_NOTICE (obj1, obj2))
2857 return 1; 2998 return 1;
2858 #ifdef WITH_NUMBER_TYPES 2999
3000 /* 2. If both numbers, compare with `='. */
2859 if (NUMBERP (obj1) && NUMBERP (obj2)) 3001 if (NUMBERP (obj1) && NUMBERP (obj2))
2860 { 3002 {
2861 switch (promote_args (&obj1, &obj2)) 3003 return (0 == bytecode_arithcompare (obj1, obj2));
2862 { 3004 }
2863 case FIXNUM_T: 3005
2864 return XREALINT (obj1) == XREALINT (obj2); 3006 /* 3. If characters, compare case-insensitively. */
2865 #ifdef HAVE_BIGNUM
2866 case BIGNUM_T:
2867 return bignum_eql (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2));
2868 #endif
2869 #ifdef HAVE_RATIO
2870 case RATIO_T:
2871 return ratio_eql (XRATIO_DATA (obj1), XRATIO_DATA (obj2));
2872 #endif
2873 case FLOAT_T:
2874 return XFLOAT_DATA (obj1) == XFLOAT_DATA (obj2);
2875 #ifdef HAVE_BIGFLOAT
2876 case BIGFLOAT_T:
2877 return bigfloat_eql (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2));
2878 #endif
2879 }
2880 }
2881 #else
2882 if ((INTP (obj1) && FLOATP (obj2)) || (FLOATP (obj1) && INTP (obj2)))
2883 return extract_float (obj1) == extract_float (obj2);
2884 #endif
2885 if (CHARP (obj1) && CHARP (obj2)) 3007 if (CHARP (obj1) && CHARP (obj2))
2886 return DOWNCASE (0, XCHAR (obj1)) == DOWNCASE (0, XCHAR (obj2)); 3008 return CANONCASE (0, XCHAR (obj1)) == CANONCASE (0, XCHAR (obj2));
3009
3010 /* 4. If arrays of different types, compare their lengths, and
3011 then compare element-by-element. */
3012 {
3013 enum array_type artype1, artype2;
3014 artype1 = array_type (obj1);
3015 artype2 = array_type (obj2);
3016 if (artype1 != artype2 && artype1 && artype2)
3017 {
3018 EMACS_INT i;
3019 EMACS_INT l1 = XINT (Flength (obj1));
3020 EMACS_INT l2 = XINT (Flength (obj2));
3021 /* Both arrays, but of different lengths */
3022 if (l1 != l2)
3023 return 0;
3024 for (i = 0; i < l1; i++)
3025 if (!internal_equalp (Faref (obj1, make_int (i)),
3026 Faref (obj2, make_int (i)), depth + 1))
3027 return 0;
3028 return 1;
3029 }
3030 }
3031 /* 5. Else, they must be the same type. If so, call the equal() method,
3032 telling it to fold case. For objects that care about case-folding
3033 their contents, the equal() method will call internal_equal_0(). */
2887 if (XTYPE (obj1) != XTYPE (obj2)) 3034 if (XTYPE (obj1) != XTYPE (obj2))
2888 return 0; 3035 return 0;
2889 if (LRECORDP (obj1)) 3036 if (LRECORDP (obj1))
2890 { 3037 {
2891 const struct lrecord_implementation 3038 const struct lrecord_implementation
2892 *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1), 3039 *imp1 = XRECORD_LHEADER_IMPLEMENTATION (obj1),
2893 *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2); 3040 *imp2 = XRECORD_LHEADER_IMPLEMENTATION (obj2);
2894 3041
2895 /* #### not yet implemented properly, needs another flag to specify
2896 equalp-ness */
2897 return (imp1 == imp2) && 3042 return (imp1 == imp2) &&
2898 /* EQ-ness of the objects was noticed above */ 3043 /* EQ-ness of the objects was noticed above */
2899 (imp1->equal && (imp1->equal) (obj1, obj2, depth)); 3044 (imp1->equal && (imp1->equal) (obj1, obj2, depth, 1));
2900 } 3045 }
2901 3046
2902 return 0; 3047 return 0;
3048 }
3049
3050 int
3051 internal_equal_0 (Lisp_Object obj1, Lisp_Object obj2, int depth, int foldcase)
3052 {
3053 if (foldcase)
3054 return internal_equalp (obj1, obj2, depth);
3055 else
3056 return internal_equal (obj1, obj2, depth);
2903 } 3057 }
2904 3058
2905 /* Note that we may be calling sub-objects that will use 3059 /* Note that we may be calling sub-objects that will use
2906 internal_equal() (instead of internal_old_equal()). Oh well. 3060 internal_equal() (instead of internal_old_equal()). Oh well.
2907 We will get an Ebola note if there's any possibility of confusion, 3061 We will get an Ebola note if there's any possibility of confusion,
2930 Numbers are compared by value. Symbols must match exactly. 3084 Numbers are compared by value. Symbols must match exactly.
2931 */ 3085 */
2932 (object1, object2)) 3086 (object1, object2))
2933 { 3087 {
2934 return internal_equal (object1, object2, 0) ? Qt : Qnil; 3088 return internal_equal (object1, object2, 0) ? Qt : Qnil;
3089 }
3090
3091 DEFUN ("equalp", Fequalp, 2, 2, 0, /*
3092 Return t if two Lisp objects have similar structure and contents.
3093
3094 This is like `equal', except that it accepts numerically equal
3095 numbers of different types (float, integer, bignum, bigfloat), and also
3096 compares strings and characters case-insensitively.
3097
3098 Type objects that are arrays (that is, strings, bit-vectors, and vectors)
3099 of the same length and with contents that are `equalp' are themselves
3100 `equalp', regardless of whether the two objects have the same type.
3101
3102 Other objects whose primary purpose is as containers of other objects are
3103 `equalp' if they would otherwise be equal (same length, type, etc.) and
3104 their contents are `equalp'. This goes for conses, weak lists,
3105 weak boxes, ephemerons, specifiers, hash tables, char tables and range
3106 tables. However, objects that happen to contain other objects but are not
3107 primarily designed for this purpose (e.g. compiled functions, events or
3108 display-related objects such as glyphs, faces or extents) are currently
3109 compared using `equalp' the same way as using `equal'.
3110
3111 More specifically, two hash tables are `equalp' if they have the same test
3112 (see `hash-table-test'), the same number of entries, and the same value for
3113 `hash-table-weakness', and if, for each entry in one hash table, its key is
3114 equivalent to a key in the other hash table using the hash table test, and
3115 its value is `equalp' to the other hash table's value for that key.
3116 */
3117 (object1, object2))
3118 {
3119 return internal_equalp (object1, object2, 0) ? Qt : Qnil;
2935 } 3120 }
2936 3121
2937 DEFUN ("old-equal", Fold_equal, 2, 2, 0, /* 3122 DEFUN ("old-equal", Fold_equal, 2, 2, 0, /*
2938 Return t if two Lisp objects have similar structure and contents. 3123 Return t if two Lisp objects have similar structure and contents.
2939 They must have the same data type. 3124 They must have the same data type.
3148 RETURN_UNGCPRO (Qnil); /* No non-nil args provided. */ 3333 RETURN_UNGCPRO (Qnil); /* No non-nil args provided. */
3149 } 3334 }
3150 3335
3151 3336
3152 /* This is the guts of several mapping functions. 3337 /* This is the guts of several mapping functions.
3153 Apply FUNCTION to each element of SEQUENCE, one by one, 3338
3154 storing the results into elements of VALS, a C vector of Lisp_Objects. 3339 Call FUNCTION CALL_COUNT times, with NSEQUENCES arguments each time,
3155 LENI is the length of VALS, which should also be the length of SEQUENCE. 3340 taking the elements from SEQUENCES. If VALS is non-NULL, store the
3156 3341 results into VALS, a C array of Lisp_Objects; else, if LISP_VALS is
3157 If VALS is a null pointer, do not accumulate the results. */ 3342 non-nil, store the results into LISP_VALS, a sequence with sufficient
3343 room for CALL_COUNT results (but see the documentation of SOME_OR_EVERY.)
3344 Else, do not accumulate any result.
3345
3346 If VALS is non-NULL, NSEQUENCES is one, and SEQUENCES[0] is a cons,
3347 mapcarX will store the elements of SEQUENCES[0] in stack and GCPRO them,
3348 so FUNCTION cannot insert a non-cons into SEQUENCES[0] and throw off
3349 mapcarX.
3350
3351 Otherwise, mapcarX signals a wrong-type-error if it encounters a
3352 non-cons, non-array when traversing SEQUENCES. Common Lisp specifies in
3353 MAPPING-DESTRUCTIVE-INTERACTION that it is an error when FUNCTION
3354 destructively modifies SEQUENCES in a way that might affect the ongoing
3355 traversal operation.
3356
3357 If SOME_OR_EVERY is SOME_OR_EVERY_SOME, return the (possibly multiple)
3358 values given by FUNCTION the first time it is non-nil, and abandon the
3359 iterations. LISP_VALS must be a cons, and the return value will be
3360 stored in its car. If SOME_OR_EVERY is SOME_OR_EVERY_EVERY, store Qnil
3361 in the car of LISP_VALS if FUNCTION gives nil; otherwise leave it
3362 alone. */
3363
3364 #define SOME_OR_EVERY_NEITHER 0
3365 #define SOME_OR_EVERY_SOME 1
3366 #define SOME_OR_EVERY_EVERY 2
3158 3367
3159 static void 3368 static void
3160 mapcar1 (Elemcount leni, Lisp_Object *vals, 3369 mapcarX (Elemcount call_count, Lisp_Object *vals, Lisp_Object lisp_vals,
3161 Lisp_Object function, Lisp_Object sequence) 3370 Lisp_Object function, int nsequences, Lisp_Object *sequences,
3162 { 3371 int some_or_every)
3163 Lisp_Object result; 3372 {
3164 Lisp_Object args[2]; 3373 Lisp_Object called, *args;
3165 struct gcpro gcpro1; 3374 struct gcpro gcpro1, gcpro2;
3166 3375 int i, j;
3167 if (vals) 3376 enum lrecord_type lisp_vals_type;
3168 { 3377
3169 GCPRO1 (vals[0]); 3378 assert (LRECORDP (lisp_vals));
3170 gcpro1.nvars = 0; 3379 lisp_vals_type = (enum lrecord_type) XRECORD_LHEADER (lisp_vals)->type;
3171 } 3380
3172 3381 args = alloca_array (Lisp_Object, nsequences + 1);
3173 args[0] = function; 3382 args[0] = function;
3174 3383 for (i = 1; i <= nsequences; ++i)
3175 if (LISTP (sequence)) 3384 {
3176 { 3385 args[i] = Qnil;
3177 /* A devious `function' could either: 3386 }
3178 - insert garbage into the list in front of us, causing XCDR to crash 3387
3179 - amputate the list behind us using (setcdr), causing the remaining 3388 if (vals != NULL)
3180 elts to lose their GCPRO status. 3389 {
3181 3390 GCPRO2 (args[0], vals[0]);
3182 if (vals != 0) we avoid this by copying the elts into the 3391 gcpro1.nvars = nsequences + 1;
3183 `vals' array. By a stroke of luck, `vals' is exactly large 3392 gcpro2.nvars = 0;
3184 enough to hold the elts left to be traversed as well as the 3393 }
3185 results computed so far. 3394 else
3186 3395 {
3187 if (vals == 0) we don't have any free space available and 3396 GCPRO1 (args[0]);
3188 don't want to eat up any more stack with ALLOCA (). 3397 gcpro1.nvars = nsequences + 1;
3189 So we use EXTERNAL_LIST_LOOP_3_NO_DECLARE and GCPRO the tail. */ 3398 }
3190 3399
3191 if (vals) 3400 /* Be extra nice in the event that we've been handed one list and one
3401 only; make it possible for FUNCTION to set cdrs not yet processed to
3402 non-cons, non-nil objects without ill-effect, if we have been handed
3403 the stack space to do that. */
3404 if (vals != NULL && 1 == nsequences && CONSP (sequences[0]))
3405 {
3406 Lisp_Object lst = sequences[0];
3407 Lisp_Object *val = vals;
3408 for (i = 0; i < call_count; ++i)
3192 { 3409 {
3193 Lisp_Object *val = vals; 3410 *val++ = XCAR (lst);
3194 Elemcount i; 3411 lst = XCDR (lst);
3195 3412 }
3196 LIST_LOOP_2 (elt, sequence) 3413 gcpro2.nvars = call_count;
3197 *val++ = elt; 3414
3198 3415 for (i = 0; i < call_count; ++i)
3199 gcpro1.nvars = leni; 3416 {
3200 3417 args[1] = vals[i];
3201 for (i = 0; i < leni; i++) 3418 vals[i] = IGNORE_MULTIPLE_VALUES (Ffuncall (nsequences + 1, args));
3419 }
3420 }
3421 else
3422 {
3423 Binbyte *sequence_types = alloca_array (Binbyte, nsequences);
3424 for (j = 0; j < nsequences; ++j)
3425 {
3426 sequence_types[j] = XRECORD_LHEADER (sequences[j])->type;
3427 }
3428
3429 for (i = 0; i < call_count; ++i)
3430 {
3431 for (j = 0; j < nsequences; ++j)
3202 { 3432 {
3203 args[1] = vals[i]; 3433 switch (sequence_types[j])
3204 vals[i] = Ffuncall (2, args); 3434 {
3435 case lrecord_type_cons:
3436 {
3437 if (!CONSP (sequences[j]))
3438 {
3439 /* This means FUNCTION has probably messed
3440 around with a cons in one of the sequences,
3441 since we checked the type
3442 (CHECK_SEQUENCE()) and the length and
3443 structure (with Flength()) correctly in our
3444 callers. */
3445 dead_wrong_type_argument (Qconsp, sequences[j]);
3446 }
3447 args[j + 1] = XCAR (sequences[j]);
3448 sequences[j] = XCDR (sequences[j]);
3449 break;
3450 }
3451 case lrecord_type_vector:
3452 {
3453 args[j + 1] = XVECTOR_DATA (sequences[j])[i];
3454 break;
3455 }
3456 case lrecord_type_string:
3457 {
3458 args[j + 1] = make_char (string_ichar (sequences[j], i));
3459 break;
3460 }
3461 case lrecord_type_bit_vector:
3462 {
3463 args[j + 1]
3464 = make_int (bit_vector_bit (XBIT_VECTOR (sequences[j]),
3465 i));
3466 break;
3467 }
3468 default:
3469 ABORT();
3470 }
3471 }
3472 called = Ffuncall (nsequences + 1, args);
3473 if (vals != NULL)
3474 {
3475 vals[i] = IGNORE_MULTIPLE_VALUES (called);
3476 gcpro2.nvars += 1;
3477 }
3478 else
3479 {
3480 switch (lisp_vals_type)
3481 {
3482 case lrecord_type_symbol:
3483 break;
3484 case lrecord_type_cons:
3485 {
3486 if (SOME_OR_EVERY_NEITHER == some_or_every)
3487 {
3488 called = IGNORE_MULTIPLE_VALUES (called);
3489 if (!CONSP (lisp_vals))
3490 {
3491 /* If FUNCTION has inserted a non-cons non-nil
3492 cdr into the list before we've processed the
3493 relevant part, error. */
3494 dead_wrong_type_argument (Qconsp, lisp_vals);
3495 }
3496
3497 XSETCAR (lisp_vals, called);
3498 lisp_vals = XCDR (lisp_vals);
3499 break;
3500 }
3501
3502 if (SOME_OR_EVERY_SOME == some_or_every)
3503 {
3504 if (!NILP (IGNORE_MULTIPLE_VALUES (called)))
3505 {
3506 XCAR (lisp_vals) = called;
3507 UNGCPRO;
3508 return;
3509 }
3510 break;
3511 }
3512
3513 if (SOME_OR_EVERY_EVERY == some_or_every)
3514 {
3515 called = IGNORE_MULTIPLE_VALUES (called);
3516 if (NILP (called))
3517 {
3518 XCAR (lisp_vals) = Qnil;
3519 UNGCPRO;
3520 return;
3521 }
3522 break;
3523 }
3524
3525 goto bad_some_or_every_flag;
3526 }
3527 case lrecord_type_vector:
3528 {
3529 called = IGNORE_MULTIPLE_VALUES (called);
3530 i < XVECTOR_LENGTH (lisp_vals) ?
3531 (XVECTOR_DATA (lisp_vals)[i] = called) :
3532 /* Let #'aset error. */
3533 Faset (lisp_vals, make_int (i), called);
3534 break;
3535 }
3536 case lrecord_type_string:
3537 {
3538 /* If this ever becomes a code hotspot, we can keep
3539 around pointers into the data of the string, checking
3540 each time that it hasn't been relocated. */
3541 called = IGNORE_MULTIPLE_VALUES (called);
3542 Faset (lisp_vals, make_int (i), called);
3543 break;
3544 }
3545 case lrecord_type_bit_vector:
3546 {
3547 called = IGNORE_MULTIPLE_VALUES (called);
3548 (BITP (called) &&
3549 i < bit_vector_length (XBIT_VECTOR (lisp_vals))) ?
3550 set_bit_vector_bit (XBIT_VECTOR (lisp_vals), i,
3551 XINT (called)) :
3552 (void) Faset (lisp_vals, make_int (i), called);
3553 break;
3554 }
3555 bad_some_or_every_flag:
3556 default:
3557 {
3558 ABORT();
3559 break;
3560 }
3561 }
3205 } 3562 }
3206 } 3563 }
3207 else 3564 }
3208 { 3565 UNGCPRO;
3209 Lisp_Object elt, tail; 3566 }
3210 EMACS_INT len_unused; 3567
3211 struct gcpro ngcpro1; 3568 DEFUN ("mapconcat", Fmapconcat, 3, MANY, 0, /*
3212 3569 Call FUNCTION on each element of SEQUENCE, and concat results to a string.
3213 NGCPRO1 (tail);
3214
3215 {
3216 EXTERNAL_LIST_LOOP_4_NO_DECLARE (elt, sequence, tail, len_unused)
3217 {
3218 args[1] = elt;
3219 Ffuncall (2, args);
3220 }
3221 }
3222
3223 NUNGCPRO;
3224 }
3225 }
3226 else if (VECTORP (sequence))
3227 {
3228 Lisp_Object *objs = XVECTOR_DATA (sequence);
3229 Elemcount i;
3230 for (i = 0; i < leni; i++)
3231 {
3232 args[1] = *objs++;
3233 result = Ffuncall (2, args);
3234 if (vals) vals[gcpro1.nvars++] = result;
3235 }
3236 }
3237 else if (STRINGP (sequence))
3238 {
3239 /* The string data of `sequence' might be relocated during GC. */
3240 Bytecount slen = XSTRING_LENGTH (sequence);
3241 Ibyte *p = alloca_ibytes (slen);
3242 Ibyte *end = p + slen;
3243
3244 memcpy (p, XSTRING_DATA (sequence), slen);
3245
3246 while (p < end)
3247 {
3248 args[1] = make_char (itext_ichar (p));
3249 INC_IBYTEPTR (p);
3250 result = Ffuncall (2, args);
3251 if (vals) vals[gcpro1.nvars++] = result;
3252 }
3253 }
3254 else if (BIT_VECTORP (sequence))
3255 {
3256 Lisp_Bit_Vector *v = XBIT_VECTOR (sequence);
3257 Elemcount i;
3258 for (i = 0; i < leni; i++)
3259 {
3260 args[1] = make_int (bit_vector_bit (v, i));
3261 result = Ffuncall (2, args);
3262 if (vals) vals[gcpro1.nvars++] = result;
3263 }
3264 }
3265 else
3266 ABORT (); /* unreachable, since Flength (sequence) did not get an error */
3267
3268 if (vals)
3269 UNGCPRO;
3270 }
3271
3272 DEFUN ("mapconcat", Fmapconcat, 3, 3, 0, /*
3273 Apply FUNCTION to each element of SEQUENCE, and concat the results to a string.
3274 Between each pair of results, insert SEPARATOR. 3570 Between each pair of results, insert SEPARATOR.
3275 3571
3276 Each result, and SEPARATOR, should be strings. Thus, using " " as SEPARATOR 3572 Each result, and SEPARATOR, should be strings. Thus, using " " as SEPARATOR
3277 results in spaces between the values returned by FUNCTION. SEQUENCE itself 3573 results in spaces between the values returned by FUNCTION. SEQUENCE itself
3278 may be a list, a vector, a bit vector, or a string. 3574 may be a list, a vector, a bit vector, or a string.
3279 */ 3575
3280 (function, sequence, separator)) 3576 With optional SEQUENCES, call FUNCTION each time with as many arguments as
3281 { 3577 there are SEQUENCES, plus one for the element from SEQUENCE. One element
3282 EMACS_INT len = XINT (Flength (sequence)); 3578 from each sequence will be used each time FUNCTION is called, and
3283 Lisp_Object *args; 3579 `mapconcat' will give up once the shortest sequence is exhausted.
3284 EMACS_INT i; 3580
3285 EMACS_INT nargs = len + len - 1; 3581 arguments: (FUNCTION SEQUENCE SEPARATOR &rest SEQUENCES)
3286 3582 */
3287 if (len == 0) return build_string (""); 3583 (int nargs, Lisp_Object *args))
3288 3584 {
3289 args = alloca_array (Lisp_Object, nargs); 3585 Lisp_Object function = args[0];
3290 3586 Lisp_Object sequence = args[1];
3291 mapcar1 (len, args, function, sequence); 3587 Lisp_Object separator = args[2];
3588 Elemcount len = EMACS_INT_MAX;
3589 Lisp_Object *args0;
3590 EMACS_INT i, nargs0;
3591
3592 args[2] = sequence;
3593 args[1] = separator;
3594
3595 for (i = 2; i < nargs; ++i)
3596 {
3597 CHECK_SEQUENCE (args[i]);
3598 len = min (len, XINT (Flength (args[i])));
3599 }
3600
3601 if (len == 0) return build_ascstring ("");
3602
3603 nargs0 = len + len - 1;
3604 args0 = alloca_array (Lisp_Object, nargs0);
3605
3606 /* Special-case this, it's very common and doesn't require any
3607 funcalls. Upside of doing it here, instead of cl-macs.el: no consing,
3608 apart from the final string, we allocate everything on the stack. */
3609 if (EQ (function, Qidentity) && 3 == nargs && CONSP (sequence))
3610 {
3611 for (i = 0; i < len; ++i)
3612 {
3613 args0[i] = XCAR (sequence);
3614 sequence = XCDR (sequence);
3615 }
3616 }
3617 else
3618 {
3619 mapcarX (len, args0, Qnil, function, nargs - 2, args + 2,
3620 SOME_OR_EVERY_NEITHER);
3621 }
3292 3622
3293 for (i = len - 1; i >= 0; i--) 3623 for (i = len - 1; i >= 0; i--)
3294 args[i + i] = args[i]; 3624 args0[i + i] = args0[i];
3295 3625
3296 for (i = 1; i < nargs; i += 2) 3626 for (i = 1; i < nargs0; i += 2)
3297 args[i] = separator; 3627 args0[i] = separator;
3298 3628
3299 return Fconcat (nargs, args); 3629 return Fconcat (nargs0, args0);
3300 } 3630 }
3301 3631
3302 DEFUN ("mapcar", Fmapcar, 2, 2, 0, /* 3632 DEFUN ("mapcar*", FmapcarX, 2, MANY, 0, /*
3303 Apply FUNCTION to each element of SEQUENCE; return a list of the results. 3633 Call FUNCTION on each element of SEQUENCE; return a list of the results.
3304 The result is a list of the same length as SEQUENCE. 3634 The result is a list of the same length as SEQUENCE.
3305 SEQUENCE may be a list, a vector, a bit vector, or a string. 3635 SEQUENCE may be a list, a vector, a bit vector, or a string.
3306 */ 3636
3307 (function, sequence)) 3637 With optional SEQUENCES, call FUNCTION each time with as many arguments as
3308 { 3638 there are SEQUENCES, plus one for the element from SEQUENCE. One element
3309 Elemcount len = XINT (Flength (sequence)); 3639 from each sequence will be used each time FUNCTION is called, and `mapcar'
3310 Lisp_Object *args = alloca_array (Lisp_Object, len); 3640 stops calling FUNCTION once the shortest sequence is exhausted.
3311 3641
3312 mapcar1 (len, args, function, sequence); 3642 arguments: (FUNCTION SEQUENCE &rest SEQUENCES)
3313 3643 */
3314 return Flist ((int) len, args); 3644 (int nargs, Lisp_Object *args))
3315 } 3645 {
3316 3646 Lisp_Object function = args[0];
3317 DEFUN ("mapvector", Fmapvector, 2, 2, 0, /* 3647 Elemcount len = EMACS_INT_MAX;
3318 Apply FUNCTION to each element of SEQUENCE; return a vector of the results. 3648 Lisp_Object *args0;
3649 int i;
3650
3651 for (i = 1; i < nargs; ++i)
3652 {
3653 CHECK_SEQUENCE (args[i]);
3654 len = min (len, XINT (Flength (args[i])));
3655 }
3656
3657 args0 = alloca_array (Lisp_Object, len);
3658 mapcarX (len, args0, Qnil, function, nargs - 1, args + 1,
3659 SOME_OR_EVERY_NEITHER);
3660
3661 return Flist ((int) len, args0);
3662 }
3663
3664 DEFUN ("mapvector", Fmapvector, 2, MANY, 0, /*
3665 Call FUNCTION on each element of SEQUENCE; return a vector of the results.
3319 The result is a vector of the same length as SEQUENCE. 3666 The result is a vector of the same length as SEQUENCE.
3320 SEQUENCE may be a list, a vector, a bit vector, or a string. 3667 SEQUENCE may be a list, a vector, a bit vector, or a string.
3321 */ 3668
3322 (function, sequence)) 3669 With optional SEQUENCES, call FUNCTION each time with as many arguments as
3323 { 3670 there are SEQUENCES, plus one for the element from SEQUENCE. One element
3324 Elemcount len = XINT (Flength (sequence)); 3671 from each sequence will be used each time FUNCTION is called, and
3325 Lisp_Object result = make_vector (len, Qnil); 3672 `mapvector' stops calling FUNCTION once the shortest sequence is exhausted.
3673
3674 arguments: (FUNCTION SEQUENCE &rest SEQUENCES)
3675 */
3676 (int nargs, Lisp_Object *args))
3677 {
3678 Lisp_Object function = args[0];
3679 Elemcount len = EMACS_INT_MAX;
3680 Lisp_Object result;
3326 struct gcpro gcpro1; 3681 struct gcpro gcpro1;
3327 3682 int i;
3683
3684 for (i = 1; i < nargs; ++i)
3685 {
3686 CHECK_SEQUENCE (args[i]);
3687 len = min (len, XINT (Flength (args[i])));
3688 }
3689
3690 result = make_vector (len, Qnil);
3328 GCPRO1 (result); 3691 GCPRO1 (result);
3329 mapcar1 (len, XVECTOR_DATA (result), function, sequence); 3692 /* Don't pass result as the lisp_object argument, we want mapcarX to protect
3693 a single list argument's elements from being garbage-collected. */
3694 mapcarX (len, XVECTOR_DATA (result), Qnil, function, nargs - 1, args +1,
3695 SOME_OR_EVERY_NEITHER);
3330 UNGCPRO; 3696 UNGCPRO;
3331 3697
3332 return result; 3698 return result;
3333 } 3699 }
3334 3700
3335 DEFUN ("mapc-internal", Fmapc_internal, 2, 2, 0, /* 3701 DEFUN ("mapcan", Fmapcan, 2, MANY, 0, /*
3336 Apply FUNCTION to each element of SEQUENCE. 3702 Call FUNCTION on each element of SEQUENCE; chain the results together.
3703
3704 FUNCTION must normally return a list; the results will be concatenated
3705 together using `nconc'.
3706
3707 With optional SEQUENCES, call FUNCTION each time with as many arguments as
3708 there are SEQUENCES, plus one for the element from SEQUENCE. One element
3709 from each sequence will be used each time FUNCTION is called, and
3710 `mapcan' stops calling FUNCTION once the shortest sequence is exhausted.
3711
3712 arguments: (FUNCTION SEQUENCE &rest SEQUENCES)
3713 */
3714 (int nargs, Lisp_Object *args))
3715 {
3716 Lisp_Object function = args[0], nconcing;
3717 Elemcount len = EMACS_INT_MAX;
3718 Lisp_Object *args0;
3719 struct gcpro gcpro1;
3720 int i;
3721
3722 for (i = 1; i < nargs; ++i)
3723 {
3724 CHECK_SEQUENCE (args[i]);
3725 len = min (len, XINT (Flength (args[i])));
3726 }
3727
3728 args0 = alloca_array (Lisp_Object, len + 1);
3729 mapcarX (len, args0 + 1, Qnil, function, nargs - 1, args + 1,
3730 SOME_OR_EVERY_NEITHER);
3731
3732 if (len < 2)
3733 {
3734 return len ? args0[1] : Qnil;
3735 }
3736
3737 /* bytecode_nconc2 can signal and return, we need to GCPRO the args, since
3738 mapcarX is no longer doing this for us. */
3739 args0[0] = Fcons (Qnil, Qnil);
3740 GCPRO1 (args0[0]);
3741 gcpro1.nvars = len + 1;
3742
3743 for (i = 0; i < len; ++i)
3744 {
3745 nconcing = bytecode_nconc2 (args0 + i);
3746 args0[i + 1] = nconcing;
3747 }
3748
3749 RETURN_UNGCPRO (XCDR (nconcing));
3750 }
3751
3752 DEFUN ("mapc", Fmapc, 2, MANY, 0, /*
3753 Call FUNCTION on each element of SEQUENCE.
3754
3337 SEQUENCE may be a list, a vector, a bit vector, or a string. 3755 SEQUENCE may be a list, a vector, a bit vector, or a string.
3338 This function is like `mapcar' but does not accumulate the results, 3756 This function is like `mapcar' but does not accumulate the results,
3339 which is more efficient if you do not use the results. 3757 which is more efficient if you do not use the results.
3340 3758
3341 The difference between this and `mapc' is that `mapc' supports all 3759 With optional SEQUENCES, call FUNCTION each time with as many arguments as
3342 the spiffy Common Lisp arguments. You should normally use `mapc'. 3760 there are SEQUENCES, plus one for the elements from SEQUENCE. One element
3343 */ 3761 from each sequence will be used each time FUNCTION is called, and
3344 (function, sequence)) 3762 `mapc' stops calling FUNCTION once the shortest sequence is exhausted.
3345 { 3763
3346 mapcar1 (XINT (Flength (sequence)), 0, function, sequence); 3764 Return SEQUENCE.
3347 3765
3348 return sequence; 3766 arguments: (FUNCTION SEQUENCE &rest SEQUENCES)
3349 } 3767 */
3350 3768 (int nargs, Lisp_Object *args))
3769 {
3770 Elemcount len = EMACS_INT_MAX;
3771 Lisp_Object sequence = args[1];
3772 struct gcpro gcpro1;
3773 int i;
3774
3775 for (i = 1; i < nargs; ++i)
3776 {
3777 CHECK_SEQUENCE (args[i]);
3778 len = min (len, XINT (Flength (args[i])));
3779 }
3780
3781 /* We need to GCPRO sequence, because mapcarX will modify the
3782 elements of the args array handed to it, and this may involve
3783 elements of sequence getting garbage collected. */
3784 GCPRO1 (sequence);
3785 mapcarX (len, NULL, Qnil, args[0], nargs - 1, args + 1,
3786 SOME_OR_EVERY_NEITHER);
3787 RETURN_UNGCPRO (sequence);
3788 }
3789
3790 DEFUN ("map", Fmap, 3, MANY, 0, /*
3791 Map FUNCTION across one or more sequences, returning a sequence.
3792
3793 TYPE is the sequence type to return, FUNCTION is the function, SEQUENCE is
3794 the first argument sequence, SEQUENCES are the other argument sequences.
3795
3796 FUNCTION will be called with (1+ (length SEQUENCES)) arguments, and must be
3797 capable of accepting this number of arguments.
3798
3799 Certain TYPEs are recognised internally by `map', but others are not, and
3800 `coerce' may throw an error on an attempt to convert to a TYPE it does not
3801 understand. A null TYPE means do not accumulate any values.
3802
3803 arguments: (TYPE FUNCTION SEQUENCE &rest SEQUENCES)
3804 */
3805 (int nargs, Lisp_Object *args))
3806 {
3807 Lisp_Object type = args[0];
3808 Lisp_Object function = args[1];
3809 Lisp_Object result = Qnil;
3810 Lisp_Object *args0 = NULL;
3811 Elemcount len = EMACS_INT_MAX;
3812 int i;
3813 struct gcpro gcpro1;
3814
3815 for (i = 2; i < nargs; ++i)
3816 {
3817 CHECK_SEQUENCE (args[i]);
3818 len = min (len, XINT (Flength (args[i])));
3819 }
3820
3821 if (!NILP (type))
3822 {
3823 args0 = alloca_array (Lisp_Object, len);
3824 }
3825
3826 mapcarX (len, args0, Qnil, function, nargs - 2, args + 2,
3827 SOME_OR_EVERY_NEITHER);
3828
3829 if (EQ (type, Qnil))
3830 {
3831 return result;
3832 }
3833
3834 if (EQ (type, Qvector) || EQ (type, Qarray))
3835 {
3836 result = Fvector (len, args0);
3837 }
3838 else if (EQ (type, Qstring))
3839 {
3840 result = Fstring (len, args0);
3841 }
3842 else if (EQ (type, Qlist))
3843 {
3844 result = Flist (len, args0);
3845 }
3846 else if (EQ (type, Qbit_vector))
3847 {
3848 result = Fbit_vector (len, args0);
3849 }
3850 else
3851 {
3852 result = Flist (len, args0);
3853 GCPRO1 (result);
3854 result = call2 (Qcoerce, result, type);
3855 UNGCPRO;
3856 }
3857
3858 return result;
3859 }
3860
3861 DEFUN ("map-into", Fmap_into, 2, MANY, 0, /*
3862 Modify RESULT-SEQUENCE using the return values of FUNCTION on SEQUENCES.
3863
3864 RESULT-SEQUENCE and SEQUENCES can be lists or arrays.
3865
3866 FUNCTION must accept at least as many arguments as there are SEQUENCES
3867 \(possibly zero). If RESULT-SEQUENCE and the elements of SEQUENCES are not
3868 the same length, stop when the shortest is exhausted; any elements of
3869 RESULT-SEQUENCE beyond that are unmodified.
3870
3871 Return RESULT-SEQUENCE.
3872
3873 arguments: (RESULT-SEQUENCE FUNCTION &rest SEQUENCES)
3874 */
3875 (int nargs, Lisp_Object *args))
3876 {
3877 Elemcount len = EMACS_INT_MAX;
3878 Lisp_Object result_sequence = args[0];
3879 Lisp_Object function = args[1];
3880 int i;
3881
3882 args[0] = function;
3883 args[1] = result_sequence;
3884
3885 for (i = 1; i < nargs; ++i)
3886 {
3887 CHECK_SEQUENCE (args[i]);
3888 len = min (len, XINT (Flength (args[i])));
3889 }
3890
3891 mapcarX (len, NULL, result_sequence, function, nargs - 2, args + 2,
3892 SOME_OR_EVERY_NEITHER);
3893
3894 return result_sequence;
3895 }
3896
3897 DEFUN ("some", Fsome, 2, MANY, 0, /*
3898 Return true if PREDICATE gives non-nil for an element of SEQUENCE.
3899
3900 If so, return the value (possibly multiple) given by PREDICATE.
3901
3902 With optional SEQUENCES, call PREDICATE each time with as many arguments as
3903 there are SEQUENCES (plus one for the element from SEQUENCE).
3904
3905 arguments: (PREDICATE SEQUENCE &rest SEQUENCES)
3906 */
3907 (int nargs, Lisp_Object *args))
3908 {
3909 Lisp_Object result_box = Fcons (Qnil, Qnil);
3910 struct gcpro gcpro1;
3911 Elemcount len = EMACS_INT_MAX;
3912 int i;
3913
3914 GCPRO1 (result_box);
3915
3916 for (i = 1; i < nargs; ++i)
3917 {
3918 CHECK_SEQUENCE (args[i]);
3919 len = min (len, XINT (Flength (args[i])));
3920 }
3921
3922 mapcarX (len, NULL, result_box, args[0], nargs - 1, args +1,
3923 SOME_OR_EVERY_SOME);
3924
3925 RETURN_UNGCPRO (XCAR (result_box));
3926 }
3927
3928 DEFUN ("every", Fevery, 2, MANY, 0, /*
3929 Return true if PREDICATE is true of every element of SEQUENCE.
3930
3931 With optional SEQUENCES, call PREDICATE each time with as many arguments as
3932 there are SEQUENCES (plus one for the element from SEQUENCE).
3933
3934 In contrast to `some', `every' never returns multiple values.
3935
3936 arguments: (PREDICATE SEQUENCE &rest SEQUENCES)
3937 */
3938 (int nargs, Lisp_Object *args))
3939 {
3940 Lisp_Object result_box = Fcons (Qt, Qnil);
3941 struct gcpro gcpro1;
3942 Elemcount len = EMACS_INT_MAX;
3943 int i;
3944
3945 GCPRO1 (result_box);
3946
3947 for (i = 1; i < nargs; ++i)
3948 {
3949 CHECK_SEQUENCE (args[i]);
3950 len = min (len, XINT (Flength (args[i])));
3951 }
3952
3953 mapcarX (len, NULL, result_box, args[0], nargs - 1, args +1,
3954 SOME_OR_EVERY_EVERY);
3955
3956 RETURN_UNGCPRO (XCAR (result_box));
3957 }
3958
3959 /* Call FUNCTION with NLISTS arguments repeatedly, each Nth argument
3960 corresponding to the result of calling (nthcdr ITERATION-COUNT LISTS[N]),
3961 until that #'nthcdr expression gives nil for some element of LISTS.
3962
3963 If MAPLP is zero, return LISTS[0]. Otherwise, return a list of the return
3964 values from FUNCTION; if NCONCP is non-zero, nconc them together.
3965
3966 In contrast to mapcarX, we don't require our callers to check LISTS for
3967 well-formedness, we signal wrong-type-argument if it's not a list, or
3968 circular-list if it's circular. */
3969
3970 static Lisp_Object
3971 maplist (Lisp_Object function, int nlists, Lisp_Object *lists, int maplp,
3972 int nconcp)
3973 {
3974 Lisp_Object result = maplp ? lists[0] : Fcons (Qnil, Qnil), funcalled;
3975 Lisp_Object nconcing[2], accum = result, *args;
3976 struct gcpro gcpro1, gcpro2, gcpro3;
3977 int i, j, continuing = (nlists > 0), called_count = 0;
3978
3979 args = alloca_array (Lisp_Object, nlists + 1);
3980 args[0] = function;
3981 for (i = 1; i <= nlists; ++i)
3982 {
3983 args[i] = Qnil;
3984 }
3985
3986 if (nconcp)
3987 {
3988 nconcing[0] = result;
3989 nconcing[1] = Qnil;
3990 GCPRO3 (args[0], nconcing[0], result);
3991 gcpro1.nvars = 1;
3992 gcpro2.nvars = 2;
3993 }
3994 else
3995 {
3996 GCPRO2 (args[0], result);
3997 gcpro1.nvars = 1;
3998 }
3999
4000 while (continuing)
4001 {
4002 for (j = 0; j < nlists; ++j)
4003 {
4004 if (CONSP (lists[j]))
4005 {
4006 args[j + 1] = lists[j];
4007 lists[j] = XCDR (lists[j]);
4008 }
4009 else if (NILP (lists[j]))
4010 {
4011 continuing = 0;
4012 break;
4013 }
4014 else
4015 {
4016 dead_wrong_type_argument (Qlistp, lists[j]);
4017 }
4018 }
4019 if (!continuing) break;
4020 funcalled = IGNORE_MULTIPLE_VALUES (Ffuncall (nlists + 1, args));
4021 if (!maplp)
4022 {
4023 if (nconcp)
4024 {
4025 /* This order of calls means we check that each list is
4026 well-formed once and once only. The last result does
4027 not have to be a list. */
4028 nconcing[1] = funcalled;
4029 nconcing[0] = bytecode_nconc2 (nconcing);
4030 }
4031 else
4032 {
4033 /* Add to the end, avoiding the need to call nreverse
4034 once we're done: */
4035 XSETCDR (accum, Fcons (funcalled, Qnil));
4036 accum = XCDR (accum);
4037 }
4038 }
4039
4040 if (++called_count % CIRCULAR_LIST_SUSPICION_LENGTH) continue;
4041
4042 for (j = 0; j < nlists; ++j)
4043 {
4044 EXTERNAL_LIST_LOOP_1 (lists[j])
4045 {
4046 /* Just check the lists aren't circular, using the
4047 EXTERNAL_LIST_LOOP_1 macro. */
4048 }
4049 }
4050 }
4051
4052 if (!maplp)
4053 {
4054 result = XCDR (result);
4055 }
4056
4057 RETURN_UNGCPRO (result);
4058 }
4059
4060 DEFUN ("maplist", Fmaplist, 2, MANY, 0, /*
4061 Call FUNCTION on each sublist of LIST and LISTS.
4062 Like `mapcar', except applies to lists and their cdr's rather than to
4063 the elements themselves."
4064
4065 arguments: (FUNCTION LIST &rest LISTS)
4066 */
4067 (int nargs, Lisp_Object *args))
4068 {
4069 return maplist (args[0], nargs - 1, args + 1, 0, 0);
4070 }
4071
4072 DEFUN ("mapl", Fmapl, 2, MANY, 0, /*
4073 Like `maplist', but do not accumulate values returned by the function.
4074
4075 arguments: (FUNCTION LIST &rest LISTS)
4076 */
4077 (int nargs, Lisp_Object *args))
4078 {
4079 return maplist (args[0], nargs - 1, args + 1, 1, 0);
4080 }
4081
4082 DEFUN ("mapcon", Fmapcon, 2, MANY, 0, /*
4083 Like `maplist', but chains together the values returned by FUNCTION.
4084
4085 FUNCTION must return a list (unless it happens to be the last
4086 iteration); the results will be concatenated together using `nconc'.
4087
4088 arguments: (FUNCTION LIST &rest LISTS)
4089 */
4090 (int nargs, Lisp_Object *args))
4091 {
4092 return maplist (args[0], nargs - 1, args + 1, 0, 1);
4093 }
3351 4094
3352 /* Extra random functions */ 4095 /* Extra random functions */
3353 4096
3354 DEFUN ("replace-list", Freplace_list, 2, 2, 0, /* 4097 DEFUN ("replace-list", Freplace_list, 2, 2, 0, /*
3355 Destructively replace the list OLD with NEW. 4098 Destructively replace the list OLD with NEW.
3389 old = Qnil; 4132 old = Qnil;
3390 4133
3391 return old; 4134 return old;
3392 } 4135 }
3393 4136
4137
3394 Lisp_Object 4138 Lisp_Object
3395 add_suffix_to_symbol (Lisp_Object symbol, const Ascbyte *ascii_string) 4139 add_suffix_to_symbol (Lisp_Object symbol, const Ascbyte *ascii_string)
3396 { 4140 {
3397 return Fintern (concat2 (Fsymbol_name (symbol), 4141 return Fintern (concat2 (Fsymbol_name (symbol),
3398 build_string (ascii_string)), 4142 build_ascstring (ascii_string)),
3399 Qnil); 4143 Qnil);
3400 } 4144 }
3401 4145
3402 Lisp_Object 4146 Lisp_Object
3403 add_prefix_to_symbol (const Ascbyte *ascii_string, Lisp_Object symbol) 4147 add_prefix_to_symbol (const Ascbyte *ascii_string, Lisp_Object symbol)
3404 { 4148 {
3405 return Fintern (concat2 (build_string (ascii_string), 4149 return Fintern (concat2 (build_ascstring (ascii_string),
3406 Fsymbol_name (symbol)), 4150 Fsymbol_name (symbol)),
3407 Qnil); 4151 Qnil);
3408 } 4152 }
3409 4153
3410 4154
3650 ((Character) < 128) 4394 ((Character) < 128)
3651 #define IS_BASE64(Character) \ 4395 #define IS_BASE64(Character) \
3652 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0) 4396 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
3653 4397
3654 /* Table of characters coding the 64 values. */ 4398 /* Table of characters coding the 64 values. */
3655 static char base64_value_to_char[64] = 4399 static Ascbyte base64_value_to_char[64] =
3656 { 4400 {
3657 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */ 4401 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
3658 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */ 4402 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
3659 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */ 4403 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
3660 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */ 4404 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
3697 `--------+--------+--------+--------' 4441 `--------+--------+--------+--------'
3698 4442
3699 The octets are divided into 6 bit chunks, which are then encoded into 4443 The octets are divided into 6 bit chunks, which are then encoded into
3700 base64 characters. */ 4444 base64 characters. */
3701 4445
3702 static DECLARE_DOESNT_RETURN (base64_conversion_error (const char *, 4446 static DECLARE_DOESNT_RETURN (base64_conversion_error (const Ascbyte *,
3703 Lisp_Object)); 4447 Lisp_Object));
3704 4448
3705 static DOESNT_RETURN 4449 static DOESNT_RETURN
3706 base64_conversion_error (const char *reason, Lisp_Object frob) 4450 base64_conversion_error (const Ascbyte *reason, Lisp_Object frob)
3707 { 4451 {
3708 signal_error (Qbase64_conversion_error, reason, frob); 4452 signal_error (Qbase64_conversion_error, reason, frob);
3709 } 4453 }
3710 4454
3711 #define ADVANCE_INPUT(c, stream) \ 4455 #define ADVANCE_INPUT(c, stream) \
3784 if (ec < 0 || IS_BASE64 (ec) || ec == '=') \ 4528 if (ec < 0 || IS_BASE64 (ec) || ec == '=') \
3785 break; \ 4529 break; \
3786 } while (1) 4530 } while (1)
3787 4531
3788 #define STORE_BYTE(pos, val, ccnt) do { \ 4532 #define STORE_BYTE(pos, val, ccnt) do { \
3789 pos += set_itext_ichar (pos, (Ichar)((unsigned char)(val))); \ 4533 pos += set_itext_ichar (pos, (Ichar)((Binbyte)(val))); \
3790 ++ccnt; \ 4534 ++ccnt; \
3791 } while (0) 4535 } while (0)
3792 4536
3793 static Bytebpos 4537 static Bytebpos
3794 base64_decode_1 (Lstream *istream, Ibyte *to, Charcount *ccptr) 4538 base64_decode_1 (Lstream *istream, Ibyte *to, Charcount *ccptr)
4027 { 4771 {
4028 INIT_LISP_OBJECT (bit_vector); 4772 INIT_LISP_OBJECT (bit_vector);
4029 4773
4030 DEFSYMBOL (Qstring_lessp); 4774 DEFSYMBOL (Qstring_lessp);
4031 DEFSYMBOL (Qidentity); 4775 DEFSYMBOL (Qidentity);
4776 DEFSYMBOL (Qvector);
4777 DEFSYMBOL (Qarray);
4778 DEFSYMBOL (Qstring);
4779 DEFSYMBOL (Qlist);
4780 DEFSYMBOL (Qbit_vector);
4781
4032 DEFSYMBOL (Qyes_or_no_p); 4782 DEFSYMBOL (Qyes_or_no_p);
4033 4783
4034 DEFERROR_STANDARD (Qbase64_conversion_error, Qconversion_error); 4784 DEFERROR_STANDARD (Qbase64_conversion_error, Qconversion_error);
4035 4785
4036 DEFSUBR (Fidentity); 4786 DEFSUBR (Fidentity);
4100 DEFSUBR (Fget); 4850 DEFSUBR (Fget);
4101 DEFSUBR (Fput); 4851 DEFSUBR (Fput);
4102 DEFSUBR (Fremprop); 4852 DEFSUBR (Fremprop);
4103 DEFSUBR (Fobject_plist); 4853 DEFSUBR (Fobject_plist);
4104 DEFSUBR (Fequal); 4854 DEFSUBR (Fequal);
4855 DEFSUBR (Fequalp);
4105 DEFSUBR (Fold_equal); 4856 DEFSUBR (Fold_equal);
4106 DEFSUBR (Ffillarray); 4857 DEFSUBR (Ffillarray);
4107 DEFSUBR (Fnconc); 4858 DEFSUBR (Fnconc);
4108 DEFSUBR (Fmapcar); 4859 DEFSUBR (FmapcarX);
4109 DEFSUBR (Fmapvector); 4860 DEFSUBR (Fmapvector);
4110 DEFSUBR (Fmapc_internal); 4861 DEFSUBR (Fmapcan);
4862 DEFSUBR (Fmapc);
4111 DEFSUBR (Fmapconcat); 4863 DEFSUBR (Fmapconcat);
4864 DEFSUBR (Fmap);
4865 DEFSUBR (Fmap_into);
4866 DEFSUBR (Fsome);
4867 DEFSUBR (Fevery);
4868 Ffset (intern ("mapc-internal"), Fsymbol_function (intern ("mapc")));
4869 Ffset (intern ("mapcar"), Fsymbol_function (intern ("mapcar*")));
4870 DEFSUBR (Fmaplist);
4871 DEFSUBR (Fmapl);
4872 DEFSUBR (Fmapcon);
4873
4112 DEFSUBR (Freplace_list); 4874 DEFSUBR (Freplace_list);
4113 DEFSUBR (Fload_average); 4875 DEFSUBR (Fload_average);
4114 DEFSUBR (Ffeaturep); 4876 DEFSUBR (Ffeaturep);
4115 DEFSUBR (Frequire); 4877 DEFSUBR (Frequire);
4116 DEFSUBR (Fprovide); 4878 DEFSUBR (Fprovide);
4128 { 4890 {
4129 DEFVAR_LISP ("path-separator", &Vpath_separator /* 4891 DEFVAR_LISP ("path-separator", &Vpath_separator /*
4130 The directory separator in search paths, as a string. 4892 The directory separator in search paths, as a string.
4131 */ ); 4893 */ );
4132 { 4894 {
4133 char c = SEPCHAR; 4895 Ascbyte c = SEPCHAR;
4134 Vpath_separator = make_string ((Ibyte *) &c, 1); 4896 Vpath_separator = make_string ((Ibyte *) &c, 1);
4135 } 4897 }
4136 } 4898 }
4137 4899
4138 void 4900 void