211
|
1 /* Random utility Lisp functions.
|
64770
|
2 Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1997,
|
|
3 1998, 1999, 2000, 2001, 2002, 2003, 2004,
|
100951
|
4 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
|
211
|
5
|
|
6 This file is part of GNU Emacs.
|
|
7
|
94963
|
8 GNU Emacs is free software: you can redistribute it and/or modify
|
211
|
9 it under the terms of the GNU General Public License as published by
|
94963
|
10 the Free Software Foundation, either version 3 of the License, or
|
|
11 (at your option) any later version.
|
211
|
12
|
|
13 GNU Emacs is distributed in the hope that it will be useful,
|
|
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
16 GNU General Public License for more details.
|
|
17
|
|
18 You should have received a copy of the GNU General Public License
|
94963
|
19 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
|
211
|
20
|
4696
|
21 #include <config.h>
|
211
|
22
|
21514
|
23 #ifdef HAVE_UNISTD_H
|
|
24 #include <unistd.h>
|
|
25 #endif
|
21841
|
26 #include <time.h>
|
21514
|
27
|
211
|
28 /* Note on some machines this defines `vector' as a typedef,
|
|
29 so make sure we don't use that name in this file. */
|
|
30 #undef vector
|
|
31 #define vector *****
|
50301
c0f3ec529c05
Allow building on Mac OS X again after Kim's merging of display code.
Andrew Choi <akochoi@shaw.ca>
diff
changeset
|
32
|
211
|
33 #include "lisp.h"
|
|
34 #include "commands.h"
|
88375
|
35 #include "character.h"
|
49081
|
36 #include "coding.h"
|
211
|
37 #include "buffer.h"
|
1513
|
38 #include "keyboard.h"
|
39697
|
39 #include "keymap.h"
|
4004
|
40 #include "intervals.h"
|
16561
|
41 #include "frame.h"
|
|
42 #include "window.h"
|
37319
|
43 #include "blockinput.h"
|
69957
YAMAMOTO Mitsuharu <mituharu@math.s.chiba-u.ac.jp>
diff
changeset
|
44 #ifdef HAVE_MENUS
|
YAMAMOTO Mitsuharu <mituharu@math.s.chiba-u.ac.jp>
diff
changeset
|
45 #if defined (HAVE_X_WINDOWS)
|
21514
|
46 #include "xterm.h"
|
69957
YAMAMOTO Mitsuharu <mituharu@math.s.chiba-u.ac.jp>
diff
changeset
|
47 #elif defined (MAC_OS)
|
YAMAMOTO Mitsuharu <mituharu@math.s.chiba-u.ac.jp>
diff
changeset
|
48 #include "macterm.h"
|
YAMAMOTO Mitsuharu <mituharu@math.s.chiba-u.ac.jp>
diff
changeset
|
49 #endif
|
21514
|
50 #endif
|
211
|
51
|
12062
|
52 #ifndef NULL
|
49081
|
53 #define NULL ((POINTER_TYPE *)0)
|
12062
|
54 #endif
|
|
55
|
18531
|
56 /* Nonzero enables use of dialog boxes for questions
|
|
57 asked by mouse commands. */
|
|
58 int use_dialog_box;
|
|
59
|
53189
|
60 /* Nonzero enables use of a file dialog for file name
|
|
61 questions asked by mouse commands. */
|
|
62 int use_file_dialog;
|
|
63
|
16561
|
64 extern int minibuffer_auto_raise;
|
|
65 extern Lisp_Object minibuf_window;
|
49081
|
66 extern Lisp_Object Vlocale_coding_system;
|
61622
|
67 extern int load_in_progress;
|
16561
|
68
|
2546
|
69 Lisp_Object Qstring_lessp, Qprovide, Qrequire;
|
4456
|
70 Lisp_Object Qyes_or_no_p_history;
|
14456
|
71 Lisp_Object Qcursor_in_echo_area;
|
20004
|
72 Lisp_Object Qwidget_type;
|
49081
|
73 Lisp_Object Qcodeset, Qdays, Qmonths, Qpaper;
|
211
|
74
|
23051
|
75 extern Lisp_Object Qinput_method_function;
|
|
76
|
65713
|
77 static int internal_equal P_ ((Lisp_Object , Lisp_Object, int, int));
|
21580
|
78
|
|
79 extern long get_random ();
|
65713
|
80 extern void seed_random P_ ((long));
|
21580
|
81
|
|
82 #ifndef HAVE_UNISTD_H
|
|
83 extern long time ();
|
|
84 #endif
|
399
|
85
|
211
|
86 DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
|
41006
|
87 doc: /* Return the argument unchanged. */)
|
39977
|
88 (arg)
|
211
|
89 Lisp_Object arg;
|
|
90 {
|
|
91 return arg;
|
|
92 }
|
|
93
|
|
94 DEFUN ("random", Frandom, Srandom, 0, 1, 0,
|
39977
|
95 doc: /* Return a pseudo-random number.
|
39899
|
96 All integers representable in Lisp are equally likely.
|
53255
|
97 On most systems, this is 29 bits' worth.
|
99419
7ef18b2a2781
* fns.c (Frandom): Rename arg N to LIMIT to match the docs; doc fix.
Juanma Barranquero <lekktu@gmail.com>
diff
changeset
|
98 With positive integer LIMIT, return random number in interval [0,LIMIT).
|
7ef18b2a2781
* fns.c (Frandom): Rename arg N to LIMIT to match the docs; doc fix.
Juanma Barranquero <lekktu@gmail.com>
diff
changeset
|
99 With argument t, set the random number seed from the current time and pid.
|
7ef18b2a2781
* fns.c (Frandom): Rename arg N to LIMIT to match the docs; doc fix.
Juanma Barranquero <lekktu@gmail.com>
diff
changeset
|
100 Other values of LIMIT are ignored. */)
|
7ef18b2a2781
* fns.c (Frandom): Rename arg N to LIMIT to match the docs; doc fix.
Juanma Barranquero <lekktu@gmail.com>
diff
changeset
|
101 (limit)
|
7ef18b2a2781
* fns.c (Frandom): Rename arg N to LIMIT to match the docs; doc fix.
Juanma Barranquero <lekktu@gmail.com>
diff
changeset
|
102 Lisp_Object limit;
|
211
|
103 {
|
12008
|
104 EMACS_INT val;
|
|
105 Lisp_Object lispy_val;
|
6376
|
106 unsigned long denominator;
|
211
|
107
|
99419
7ef18b2a2781
* fns.c (Frandom): Rename arg N to LIMIT to match the docs; doc fix.
Juanma Barranquero <lekktu@gmail.com>
diff
changeset
|
108 if (EQ (limit, Qt))
|
12008
|
109 seed_random (getpid () + time (NULL));
|
99419
7ef18b2a2781
* fns.c (Frandom): Rename arg N to LIMIT to match the docs; doc fix.
Juanma Barranquero <lekktu@gmail.com>
diff
changeset
|
110 if (NATNUMP (limit) && XFASTINT (limit) != 0)
|
211
|
111 {
|
10411
|
112 /* Try to take our random number from the higher bits of VAL,
|
|
113 not the lower, since (says Gentzel) the low bits of `random'
|
|
114 are less random than the higher ones. We do this by using the
|
|
115 quotient rather than the remainder. At the high end of the RNG
|
14091
34911b128a47
(Frandom, Flength, Felt, Fsort, Fchar_table_subtype, Fchar_table_parent,
Erik Naggum <erik@naggum.no>
diff
changeset
|
116 it's possible to get a quotient larger than n; discarding
|
10411
|
117 these values eliminates the bias that would otherwise appear
|
14091
34911b128a47
(Frandom, Flength, Felt, Fsort, Fchar_table_subtype, Fchar_table_parent,
Erik Naggum <erik@naggum.no>
diff
changeset
|
118 when using a large n. */
|
99419
7ef18b2a2781
* fns.c (Frandom): Rename arg N to LIMIT to match the docs; doc fix.
Juanma Barranquero <lekktu@gmail.com>
diff
changeset
|
119 denominator = ((unsigned long)1 << VALBITS) / XFASTINT (limit);
|
10411
|
120 do
|
10485
|
121 val = get_random () / denominator;
|
99419
7ef18b2a2781
* fns.c (Frandom): Rename arg N to LIMIT to match the docs; doc fix.
Juanma Barranquero <lekktu@gmail.com>
diff
changeset
|
122 while (val >= XFASTINT (limit));
|
211
|
123 }
|
6376
|
124 else
|
10485
|
125 val = get_random ();
|
12008
|
126 XSETINT (lispy_val, val);
|
|
127 return lispy_val;
|
211
|
128 }
|
|
129
|
|
130 /* Random data-structure functions */
|
|
131
|
|
132 DEFUN ("length", Flength, Slength, 1, 1, 0,
|
39977
|
133 doc: /* Return the length of vector, list or string SEQUENCE.
|
39899
|
134 A byte-code function object is also allowed.
|
47762
|
135 If the string contains multibyte characters, this is not necessarily
|
39899
|
136 the number of bytes in the string; it is the number of characters.
|
73926
21f6be2e8ecb
(Frandom, Flength, Fsafe_length, Fstring_bytes, Fstring_equal, Fcompare_strings,
Juanma Barranquero <lekktu@gmail.com>
diff
changeset
|
137 To get the number of bytes, use `string-bytes'. */)
|
39977
|
138 (sequence)
|
14091
34911b128a47
(Frandom, Flength, Felt, Fsort, Fchar_table_subtype, Fchar_table_parent,
Erik Naggum <erik@naggum.no>
diff
changeset
|
139 register Lisp_Object sequence;
|
211
|
140 {
|
34961
|
141 register Lisp_Object val;
|
211
|
142 register int i;
|
|
143
|
14091
34911b128a47
(Frandom, Flength, Felt, Fsort, Fchar_table_subtype, Fchar_table_parent,
Erik Naggum <erik@naggum.no>
diff
changeset
|
144 if (STRINGP (sequence))
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
145 XSETFASTINT (val, SCHARS (sequence));
|
14091
34911b128a47
(Frandom, Flength, Felt, Fsort, Fchar_table_subtype, Fchar_table_parent,
Erik Naggum <erik@naggum.no>
diff
changeset
|
146 else if (VECTORP (sequence))
|
74163
|
147 XSETFASTINT (val, ASIZE (sequence));
|
14091
34911b128a47
(Frandom, Flength, Felt, Fsort, Fchar_table_subtype, Fchar_table_parent,
Erik Naggum <erik@naggum.no>
diff
changeset
|
148 else if (CHAR_TABLE_P (sequence))
|
26856
|
149 XSETFASTINT (val, MAX_CHAR);
|
14091
34911b128a47
(Frandom, Flength, Felt, Fsort, Fchar_table_subtype, Fchar_table_parent,
Erik Naggum <erik@naggum.no>
diff
changeset
|
150 else if (BOOL_VECTOR_P (sequence))
|
34911b128a47
(Frandom, Flength, Felt, Fsort, Fchar_table_subtype, Fchar_table_parent,
Erik Naggum <erik@naggum.no>
diff
changeset
|
151 XSETFASTINT (val, XBOOL_VECTOR (sequence)->size);
|
34911b128a47
(Frandom, Flength, Felt, Fsort, Fchar_table_subtype, Fchar_table_parent,
Erik Naggum <erik@naggum.no>
diff
changeset
|
152 else if (COMPILEDP (sequence))
|
74163
|
153 XSETFASTINT (val, ASIZE (sequence) & PSEUDOVECTOR_SIZE_MASK);
|
14091
34911b128a47
(Frandom, Flength, Felt, Fsort, Fchar_table_subtype, Fchar_table_parent,
Erik Naggum <erik@naggum.no>
diff
changeset
|
154 else if (CONSP (sequence))
|
211
|
155 {
|
26256
|
156 i = 0;
|
|
157 while (CONSP (sequence))
|
211
|
158 {
|
26230
|
159 sequence = XCDR (sequence);
|
26256
|
160 ++i;
|
|
161
|
|
162 if (!CONSP (sequence))
|
|
163 break;
|
|
164
|
|
165 sequence = XCDR (sequence);
|
|
166 ++i;
|
|
167 QUIT;
|
211
|
168 }
|
|
169
|
71833
|
170 CHECK_LIST_END (sequence, sequence);
|
26230
|
171
|
|
172 val = make_number (i);
|
211
|
173 }
|
14091
34911b128a47
(Frandom, Flength, Felt, Fsort, Fchar_table_subtype, Fchar_table_parent,
Erik Naggum <erik@naggum.no>
diff
changeset
|
174 else if (NILP (sequence))
|
9965
|
175 XSETFASTINT (val, 0);
|
211
|
176 else
|
71979
|
177 wrong_type_argument (Qsequencep, sequence);
|
71833
|
178
|
9965
|
179 return val;
|
211
|
180 }
|
|
181
|
61723
|
182 /* This does not check for quits. That is safe since it must terminate. */
|
12466
|
183
|
|
184 DEFUN ("safe-length", Fsafe_length, Ssafe_length, 1, 1, 0,
|
39977
|
185 doc: /* Return the length of a list, but avoid error or infinite loop.
|
39899
|
186 This function never gets an error. If LIST is not really a list,
|
|
187 it returns 0. If LIST is circular, it returns a finite value
|
73926
21f6be2e8ecb
(Frandom, Flength, Fsafe_length, Fstring_bytes, Fstring_equal, Fcompare_strings,
Juanma Barranquero <lekktu@gmail.com>
diff
changeset
|
188 which is at least the number of distinct elements. */)
|
39977
|
189 (list)
|
12466
|
190 Lisp_Object list;
|
|
191 {
|
|
192 Lisp_Object tail, halftail, length;
|
|
193 int len = 0;
|
|
194
|
|
195 /* halftail is used to detect circular lists. */
|
|
196 halftail = list;
|
25645
|
197 for (tail = list; CONSP (tail); tail = XCDR (tail))
|
12466
|
198 {
|
|
199 if (EQ (tail, halftail) && len != 0)
|
12618
|
200 break;
|
12466
|
201 len++;
|
13344
30e17254a280
(Fsafe_length): Add missing parentheses around & within comparison.
Richard M. Stallman <rms@gnu.org>
diff
changeset
|
202 if ((len & 1) == 0)
|
25645
|
203 halftail = XCDR (halftail);
|
12466
|
204 }
|
|
205
|
|
206 XSETINT (length, len);
|
|
207 return length;
|
|
208 }
|
|
209
|
49246
|
210 DEFUN ("string-bytes", Fstring_bytes, Sstring_bytes, 1, 1, 0,
|
39977
|
211 doc: /* Return the number of bytes in STRING.
|
90667
|
212 If STRING is multibyte, this may be greater than the length of STRING. */)
|
39977
|
213 (string)
|
20881
|
214 Lisp_Object string;
|
20864
|
215 {
|
40656
|
216 CHECK_STRING (string);
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
217 return make_number (SBYTES (string));
|
20864
|
218 }
|
|
219
|
211
|
220 DEFUN ("string-equal", Fstring_equal, Sstring_equal, 2, 2, 0,
|
39977
|
221 doc: /* Return t if two strings have identical contents.
|
39899
|
222 Case is significant, but text properties are ignored.
|
73926
21f6be2e8ecb
(Frandom, Flength, Fsafe_length, Fstring_bytes, Fstring_equal, Fcompare_strings,
Juanma Barranquero <lekktu@gmail.com>
diff
changeset
|
223 Symbols are also allowed; their print names are used instead. */)
|
39977
|
224 (s1, s2)
|
211
|
225 register Lisp_Object s1, s2;
|
|
226 {
|
9128
04a702d7f662
(Frandom, Flength, Fstring_equal, Fstring_lessp, Fcopy_sequence, concat, Felt,
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
227 if (SYMBOLP (s1))
|
45401
|
228 s1 = SYMBOL_NAME (s1);
|
9128
04a702d7f662
(Frandom, Flength, Fstring_equal, Fstring_lessp, Fcopy_sequence, concat, Felt,
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
229 if (SYMBOLP (s2))
|
45401
|
230 s2 = SYMBOL_NAME (s2);
|
40656
|
231 CHECK_STRING (s1);
|
|
232 CHECK_STRING (s2);
|
211
|
233
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
234 if (SCHARS (s1) != SCHARS (s2)
|
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
235 || SBYTES (s1) != SBYTES (s2)
|
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
236 || bcmp (SDATA (s1), SDATA (s2), SBYTES (s1)))
|
211
|
237 return Qnil;
|
|
238 return Qt;
|
|
239 }
|
|
240
|
21671
|
241 DEFUN ("compare-strings", Fcompare_strings,
|
21673
|
242 Scompare_strings, 6, 7, 0,
|
39977
|
243 doc: /* Compare the contents of two strings, converting to multibyte if needed.
|
39899
|
244 In string STR1, skip the first START1 characters and stop at END1.
|
|
245 In string STR2, skip the first START2 characters and stop at END2.
|
|
246 END1 and END2 default to the full lengths of the respective strings.
|
|
247
|
|
248 Case is significant in this comparison if IGNORE-CASE is nil.
|
|
249 Unibyte strings are converted to multibyte for comparison.
|
|
250
|
|
251 The value is t if the strings (or specified portions) match.
|
|
252 If string STR1 is less, the value is a negative number N;
|
|
253 - 1 - N is the number of characters that match at the beginning.
|
|
254 If string STR1 is greater, the value is a positive number N;
|
73926
21f6be2e8ecb
(Frandom, Flength, Fsafe_length, Fstring_bytes, Fstring_equal, Fcompare_strings,
Juanma Barranquero <lekktu@gmail.com>
diff
changeset
|
255 N - 1 is the number of characters that match at the beginning. */)
|
39977
|
256 (str1, start1, end1, str2, start2, end2, ignore_case)
|
21671
|
257 Lisp_Object str1, start1, end1, start2, str2, end2, ignore_case;
|
|
258 {
|
|
259 register int end1_char, end2_char;
|
|
260 register int i1, i1_byte, i2, i2_byte;
|
|
261
|
40656
|
262 CHECK_STRING (str1);
|
|
263 CHECK_STRING (str2);
|
21671
|
264 if (NILP (start1))
|
|
265 start1 = make_number (0);
|
|
266 if (NILP (start2))
|
|
267 start2 = make_number (0);
|
40656
|
268 CHECK_NATNUM (start1);
|
|
269 CHECK_NATNUM (start2);
|
21671
|
270 if (! NILP (end1))
|
40656
|
271 CHECK_NATNUM (end1);
|
21671
|
272 if (! NILP (end2))
|
40656
|
273 CHECK_NATNUM (end2);
|
21671
|
274
|
|
275 i1 = XINT (start1);
|
|
276 i2 = XINT (start2);
|
|
277
|
|
278 i1_byte = string_char_to_byte (str1, i1);
|
|
279 i2_byte = string_char_to_byte (str2, i2);
|
|
280
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
281 end1_char = SCHARS (str1);
|
21671
|
282 if (! NILP (end1) && end1_char > XINT (end1))
|
|
283 end1_char = XINT (end1);
|
|
284
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
285 end2_char = SCHARS (str2);
|
21671
|
286 if (! NILP (end2) && end2_char > XINT (end2))
|
|
287 end2_char = XINT (end2);
|
|
288
|
|
289 while (i1 < end1_char && i2 < end2_char)
|
|
290 {
|
|
291 /* When we find a mismatch, we must compare the
|
|
292 characters, not just the bytes. */
|
|
293 int c1, c2;
|
|
294
|
|
295 if (STRING_MULTIBYTE (str1))
|
29010
|
296 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c1, str1, i1, i1_byte);
|
21671
|
297 else
|
|
298 {
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
299 c1 = SREF (str1, i1++);
|
21671
|
300 c1 = unibyte_char_to_multibyte (c1);
|
|
301 }
|
|
302
|
|
303 if (STRING_MULTIBYTE (str2))
|
29010
|
304 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c2, str2, i2, i2_byte);
|
21671
|
305 else
|
|
306 {
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
307 c2 = SREF (str2, i2++);
|
21671
|
308 c2 = unibyte_char_to_multibyte (c2);
|
|
309 }
|
|
310
|
|
311 if (c1 == c2)
|
|
312 continue;
|
|
313
|
|
314 if (! NILP (ignore_case))
|
|
315 {
|
|
316 Lisp_Object tem;
|
|
317
|
|
318 tem = Fupcase (make_number (c1));
|
|
319 c1 = XINT (tem);
|
|
320 tem = Fupcase (make_number (c2));
|
|
321 c2 = XINT (tem);
|
|
322 }
|
|
323
|
|
324 if (c1 == c2)
|
|
325 continue;
|
|
326
|
|
327 /* Note that I1 has already been incremented
|
|
328 past the character that we are comparing;
|
|
329 hence we don't add or subtract 1 here. */
|
|
330 if (c1 < c2)
|
37309
|
331 return make_number (- i1 + XINT (start1));
|
21671
|
332 else
|
37309
|
333 return make_number (i1 - XINT (start1));
|
21671
|
334 }
|
|
335
|
|
336 if (i1 < end1_char)
|
|
337 return make_number (i1 - XINT (start1) + 1);
|
|
338 if (i2 < end2_char)
|
|
339 return make_number (- i1 + XINT (start1) - 1);
|
|
340
|
|
341 return Qt;
|
|
342 }
|
|
343
|
211
|
344 DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0,
|
39977
|
345 doc: /* Return t if first arg string is less than second in lexicographic order.
|
39899
|
346 Case is significant.
|
73926
21f6be2e8ecb
(Frandom, Flength, Fsafe_length, Fstring_bytes, Fstring_equal, Fcompare_strings,
Juanma Barranquero <lekktu@gmail.com>
diff
changeset
|
347 Symbols are also allowed; their print names are used instead. */)
|
39977
|
348 (s1, s2)
|
211
|
349 register Lisp_Object s1, s2;
|
|
350 {
|
|
351 register int end;
|
20667
|
352 register int i1, i1_byte, i2, i2_byte;
|
211
|
353
|
9128
04a702d7f662
(Frandom, Flength, Fstring_equal, Fstring_lessp, Fcopy_sequence, concat, Felt,
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
354 if (SYMBOLP (s1))
|
45401
|
355 s1 = SYMBOL_NAME (s1);
|
9128
04a702d7f662
(Frandom, Flength, Fstring_equal, Fstring_lessp, Fcopy_sequence, concat, Felt,
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
356 if (SYMBOLP (s2))
|
45401
|
357 s2 = SYMBOL_NAME (s2);
|
40656
|
358 CHECK_STRING (s1);
|
|
359 CHECK_STRING (s2);
|
211
|
360
|
20667
|
361 i1 = i1_byte = i2 = i2_byte = 0;
|
|
362
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
363 end = SCHARS (s1);
|
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
364 if (end > SCHARS (s2))
|
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
365 end = SCHARS (s2);
|
20667
|
366
|
|
367 while (i1 < end)
|
|
368 {
|
|
369 /* When we find a mismatch, we must compare the
|
|
370 characters, not just the bytes. */
|
|
371 int c1, c2;
|
211
|
372
|
29010
|
373 FETCH_STRING_CHAR_ADVANCE (c1, s1, i1, i1_byte);
|
|
374 FETCH_STRING_CHAR_ADVANCE (c2, s2, i2, i2_byte);
|
20667
|
375
|
|
376 if (c1 != c2)
|
|
377 return c1 < c2 ? Qt : Qnil;
|
211
|
378 }
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
379 return i1 < SCHARS (s2) ? Qt : Qnil;
|
211
|
380 }
|
|
381
|
72609
|
382 #if __GNUC__
|
|
383 /* "gcc -O3" enables automatic function inlining, which optimizes out
|
|
384 the arguments for the invocations of this function, whereas it
|
|
385 expects these values on the stack. */
|
74163
|
386 static Lisp_Object concat P_ ((int nargs, Lisp_Object *args, enum Lisp_Type target_type, int last_special)) __attribute__((noinline));
|
74101
|
387 #else /* !__GNUC__ */
|
74163
|
388 static Lisp_Object concat P_ ((int nargs, Lisp_Object *args, enum Lisp_Type target_type, int last_special));
|
72609
|
389 #endif
|
211
|
390
|
|
391 /* ARGSUSED */
|
|
392 Lisp_Object
|
|
393 concat2 (s1, s2)
|
|
394 Lisp_Object s1, s2;
|
|
395 {
|
|
396 #ifdef NO_ARG_ARRAY
|
|
397 Lisp_Object args[2];
|
|
398 args[0] = s1;
|
|
399 args[1] = s2;
|
|
400 return concat (2, args, Lisp_String, 0);
|
|
401 #else
|
|
402 return concat (2, &s1, Lisp_String, 0);
|
|
403 #endif /* NO_ARG_ARRAY */
|
|
404 }
|
|
405
|
8966
|
406 /* ARGSUSED */
|
|
407 Lisp_Object
|
|
408 concat3 (s1, s2, s3)
|
|
409 Lisp_Object s1, s2, s3;
|
|
410 {
|
|
411 #ifdef NO_ARG_ARRAY
|
|
412 Lisp_Object args[3];
|
|
413 args[0] = s1;
|
|
414 args[1] = s2;
|
|
415 args[2] = s3;
|
|
416 return concat (3, args, Lisp_String, 0);
|
|
417 #else
|
|
418 return concat (3, &s1, Lisp_String, 0);
|
|
419 #endif /* NO_ARG_ARRAY */
|
|
420 }
|
|
421
|
211
|
422 DEFUN ("append", Fappend, Sappend, 0, MANY, 0,
|
39977
|
423 doc: /* Concatenate all the arguments and make the result a list.
|
39899
|
424 The result is a list whose elements are the elements of all the arguments.
|
|
425 Each argument may be a list, vector or string.
|
40132
75fe73bea452
(Fappend, Fconcat, Fvconcat, Fnconc, Fwidget_apply, Fmake_hash_table):
Miles Bader <miles@gnu.org>
diff
changeset
|
426 The last argument is not copied, just used as the tail of the new list.
|
75fe73bea452
(Fappend, Fconcat, Fvconcat, Fnconc, Fwidget_apply, Fmake_hash_table):
Miles Bader <miles@gnu.org>
diff
changeset
|
427 usage: (append &rest SEQUENCES) */)
|
39977
|
428 (nargs, args)
|
211
|
429 int nargs;
|
|
430 Lisp_Object *args;
|
|
431 {
|
|
432 return concat (nargs, args, Lisp_Cons, 1);
|
|
433 }
|
|
434
|
|
435 DEFUN ("concat", Fconcat, Sconcat, 0, MANY, 0,
|
39977
|
436 doc: /* Concatenate all the arguments and make the result a string.
|
39899
|
437 The result is a string whose elements are the elements of all the arguments.
|
40132
75fe73bea452
(Fappend, Fconcat, Fvconcat, Fnconc, Fwidget_apply, Fmake_hash_table):
Miles Bader <miles@gnu.org>
diff
changeset
|
438 Each argument may be a string or a list or vector of characters (integers).
|
75fe73bea452
(Fappend, Fconcat, Fvconcat, Fnconc, Fwidget_apply, Fmake_hash_table):
Miles Bader <miles@gnu.org>
diff
changeset
|
439 usage: (concat &rest SEQUENCES) */)
|
39977
|
440 (nargs, args)
|
211
|
441 int nargs;
|
|
442 Lisp_Object *args;
|
|
443 {
|
|
444 return concat (nargs, args, Lisp_String, 0);
|
|
445 }
|
|
446
|
|
447 DEFUN ("vconcat", Fvconcat, Svconcat, 0, MANY, 0,
|
39977
|
448 doc: /* Concatenate all the arguments and make the result a vector.
|
39899
|
449 The result is a vector whose elements are the elements of all the arguments.
|
40132
75fe73bea452
(Fappend, Fconcat, Fvconcat, Fnconc, Fwidget_apply, Fmake_hash_table):
Miles Bader <miles@gnu.org>
diff
changeset
|
450 Each argument may be a list, vector or string.
|
75fe73bea452
(Fappend, Fconcat, Fvconcat, Fnconc, Fwidget_apply, Fmake_hash_table):
Miles Bader <miles@gnu.org>
diff
changeset
|
451 usage: (vconcat &rest SEQUENCES) */)
|
39977
|
452 (nargs, args)
|
211
|
453 int nargs;
|
|
454 Lisp_Object *args;
|
|
455 {
|
10006
|
456 return concat (nargs, args, Lisp_Vectorlike, 0);
|
211
|
457 }
|
|
458
|
17318
|
459
|
211
|
460 DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0,
|
48320
|
461 doc: /* Return a copy of a list, vector, string or char-table.
|
39899
|
462 The elements of a list or vector are not copied; they are shared
|
73926
21f6be2e8ecb
(Frandom, Flength, Fsafe_length, Fstring_bytes, Fstring_equal, Fcompare_strings,
Juanma Barranquero <lekktu@gmail.com>
diff
changeset
|
463 with the original. */)
|
39977
|
464 (arg)
|
211
|
465 Lisp_Object arg;
|
|
466 {
|
485
|
467 if (NILP (arg)) return arg;
|
13140
|
468
|
|
469 if (CHAR_TABLE_P (arg))
|
|
470 {
|
88375
|
471 return copy_char_table (arg);
|
13140
|
472 }
|
|
473
|
|
474 if (BOOL_VECTOR_P (arg))
|
|
475 {
|
|
476 Lisp_Object val;
|
|
477 int size_in_chars
|
55161
beac72c0215f
(Fcopy_sequence, concat, internal_equal, Ffillarray, mapcar1): Use
Andreas Schwab <schwab@suse.de>
diff
changeset
|
478 = ((XBOOL_VECTOR (arg)->size + BOOL_VECTOR_BITS_PER_CHAR - 1)
|
beac72c0215f
(Fcopy_sequence, concat, internal_equal, Ffillarray, mapcar1): Use
Andreas Schwab <schwab@suse.de>
diff
changeset
|
479 / BOOL_VECTOR_BITS_PER_CHAR);
|
13140
|
480
|
|
481 val = Fmake_bool_vector (Flength (arg), Qnil);
|
|
482 bcopy (XBOOL_VECTOR (arg)->data, XBOOL_VECTOR (val)->data,
|
|
483 size_in_chars);
|
|
484 return val;
|
|
485 }
|
|
486
|
9128
04a702d7f662
(Frandom, Flength, Fstring_equal, Fstring_lessp, Fcopy_sequence, concat, Felt,
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
487 if (!CONSP (arg) && !VECTORP (arg) && !STRINGP (arg))
|
71833
|
488 wrong_type_argument (Qsequencep, arg);
|
|
489
|
211
|
490 return concat (1, &arg, CONSP (arg) ? Lisp_Cons : XTYPE (arg), 0);
|
|
491 }
|
|
492
|
25093
|
493 /* This structure holds information of an argument of `concat' that is
|
|
494 a string and has text properties to be copied. */
|
25094
|
495 struct textprop_rec
|
25093
|
496 {
|
|
497 int argnum; /* refer to ARGS (arguments of `concat') */
|
|
498 int from; /* refer to ARGS[argnum] (argument string) */
|
|
499 int to; /* refer to VAL (the target string) */
|
|
500 };
|
|
501
|
211
|
502 static Lisp_Object
|
|
503 concat (nargs, args, target_type, last_special)
|
|
504 int nargs;
|
|
505 Lisp_Object *args;
|
|
506 enum Lisp_Type target_type;
|
|
507 int last_special;
|
|
508 {
|
|
509 Lisp_Object val;
|
|
510 register Lisp_Object tail;
|
|
511 register Lisp_Object this;
|
|
512 int toindex;
|
31533
|
513 int toindex_byte = 0;
|
20607
|
514 register int result_len;
|
|
515 register int result_len_byte;
|
211
|
516 register int argnum;
|
|
517 Lisp_Object last_tail;
|
|
518 Lisp_Object prev;
|
20607
|
519 int some_multibyte;
|
25093
|
520 /* When we make a multibyte string, we can't copy text properties
|
|
521 while concatinating each string because the length of resulting
|
|
522 string can't be decided until we finish the whole concatination.
|
|
523 So, we record strings that have text properties to be copied
|
|
524 here, and copy the text properties after the concatination. */
|
31533
|
525 struct textprop_rec *textprops = NULL;
|
25094
|
526 /* Number of elments in textprops. */
|
|
527 int num_textprops = 0;
|
58623
|
528 USE_SAFE_ALLOCA;
|
211
|
529
|
31533
|
530 tail = Qnil;
|
|
531
|
211
|
532 /* In append, the last arg isn't treated like the others */
|
|
533 if (last_special && nargs > 0)
|
|
534 {
|
|
535 nargs--;
|
|
536 last_tail = args[nargs];
|
|
537 }
|
|
538 else
|
|
539 last_tail = Qnil;
|
|
540
|
71833
|
541 /* Check each argument. */
|
211
|
542 for (argnum = 0; argnum < nargs; argnum++)
|
|
543 {
|
|
544 this = args[argnum];
|
9128
04a702d7f662
(Frandom, Flength, Fstring_equal, Fstring_lessp, Fcopy_sequence, concat, Felt,
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
545 if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
|
13140
|
546 || COMPILEDP (this) || BOOL_VECTOR_P (this)))
|
71833
|
547 wrong_type_argument (Qsequencep, this);
|
211
|
548 }
|
|
549
|
20607
|
550 /* Compute total length in chars of arguments in RESULT_LEN.
|
|
551 If desired output is a string, also compute length in bytes
|
|
552 in RESULT_LEN_BYTE, and determine in SOME_MULTIBYTE
|
|
553 whether the result should be a multibyte string. */
|
|
554 result_len_byte = 0;
|
|
555 result_len = 0;
|
|
556 some_multibyte = 0;
|
|
557 for (argnum = 0; argnum < nargs; argnum++)
|
211
|
558 {
|
20607
|
559 int len;
|
211
|
560 this = args[argnum];
|
20607
|
561 len = XFASTINT (Flength (this));
|
|
562 if (target_type == Lisp_String)
|
18311
|
563 {
|
20667
|
564 /* We must count the number of bytes needed in the string
|
|
565 as well as the number of characters. */
|
18311
|
566 int i;
|
|
567 Lisp_Object ch;
|
20607
|
568 int this_len_byte;
|
18311
|
569
|
19278
|
570 if (VECTORP (this))
|
20607
|
571 for (i = 0; i < len; i++)
|
19278
|
572 {
|
74163
|
573 ch = AREF (this, i);
|
90533
|
574 CHECK_CHARACTER (ch);
|
23128
|
575 this_len_byte = CHAR_BYTES (XINT (ch));
|
20607
|
576 result_len_byte += this_len_byte;
|
89527
|
577 if (! ASCII_CHAR_P (XINT (ch)) && ! CHAR_BYTE8_P (XINT (ch)))
|
20607
|
578 some_multibyte = 1;
|
19278
|
579 }
|
20813
|
580 else if (BOOL_VECTOR_P (this) && XBOOL_VECTOR (this)->size > 0)
|
|
581 wrong_type_argument (Qintegerp, Faref (this, make_number (0)));
|
20607
|
582 else if (CONSP (this))
|
25645
|
583 for (; CONSP (this); this = XCDR (this))
|
19278
|
584 {
|
25645
|
585 ch = XCAR (this);
|
90533
|
586 CHECK_CHARACTER (ch);
|
23128
|
587 this_len_byte = CHAR_BYTES (XINT (ch));
|
20607
|
588 result_len_byte += this_len_byte;
|
89527
|
589 if (! ASCII_CHAR_P (XINT (ch)) && ! CHAR_BYTE8_P (XINT (ch)))
|
20607
|
590 some_multibyte = 1;
|
19278
|
591 }
|
20639
|
592 else if (STRINGP (this))
|
20607
|
593 {
|
20699
|
594 if (STRING_MULTIBYTE (this))
|
20667
|
595 {
|
|
596 some_multibyte = 1;
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
597 result_len_byte += SBYTES (this);
|
20667
|
598 }
|
|
599 else
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
600 result_len_byte += count_size_as_multibyte (SDATA (this),
|
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
601 SCHARS (this));
|
20607
|
602 }
|
18311
|
603 }
|
20607
|
604
|
|
605 result_len += len;
|
101587
|
606 if (result_len < 0)
|
|
607 error ("String overflow");
|
211
|
608 }
|
|
609
|
20667
|
610 if (! some_multibyte)
|
|
611 result_len_byte = result_len;
|
211
|
612
|
20607
|
613 /* Create the output object. */
|
|
614 if (target_type == Lisp_Cons)
|
|
615 val = Fmake_list (make_number (result_len), Qnil);
|
|
616 else if (target_type == Lisp_Vectorlike)
|
|
617 val = Fmake_vector (make_number (result_len), Qnil);
|
21260
|
618 else if (some_multibyte)
|
|
619 val = make_uninit_multibyte_string (result_len, result_len_byte);
|
20607
|
620 else
|
21260
|
621 val = make_uninit_string (result_len);
|
20607
|
622
|
20667
|
623 /* In `append', if all but last arg are nil, return last arg. */
|
|
624 if (target_type == Lisp_Cons && EQ (val, Qnil))
|
|
625 return last_tail;
|
20607
|
626
|
|
627 /* Copy the contents of the args into the result. */
|
211
|
628 if (CONSP (val))
|
25093
|
629 tail = val, toindex = -1; /* -1 in toindex is flag we are making a list */
|
211
|
630 else
|
20607
|
631 toindex = 0, toindex_byte = 0;
|
211
|
632
|
|
633 prev = Qnil;
|
25093
|
634 if (STRINGP (val))
|
58623
|
635 SAFE_ALLOCA (textprops, struct textprop_rec *, sizeof (struct textprop_rec) * nargs);
|
25093
|
636
|
211
|
637 for (argnum = 0; argnum < nargs; argnum++)
|
|
638 {
|
|
639 Lisp_Object thislen;
|
31533
|
640 int thisleni = 0;
|
16863
|
641 register unsigned int thisindex = 0;
|
20607
|
642 register unsigned int thisindex_byte = 0;
|
211
|
643
|
|
644 this = args[argnum];
|
|
645 if (!CONSP (this))
|
|
646 thislen = Flength (this), thisleni = XINT (thislen);
|
|
647
|
20607
|
648 /* Between strings of the same kind, copy fast. */
|
|
649 if (STRINGP (this) && STRINGP (val)
|
|
650 && STRING_MULTIBYTE (this) == some_multibyte)
|
4004
|
651 {
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
652 int thislen_byte = SBYTES (this);
|
25093
|
653
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
654 bcopy (SDATA (this), SDATA (val) + toindex_byte,
|
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
655 SBYTES (this));
|
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
656 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
|
25093
|
657 {
|
25094
|
658 textprops[num_textprops].argnum = argnum;
|
55481
|
659 textprops[num_textprops].from = 0;
|
25094
|
660 textprops[num_textprops++].to = toindex;
|
25093
|
661 }
|
20607
|
662 toindex_byte += thislen_byte;
|
55481
|
663 toindex += thisleni;
|
|
664 STRING_SET_CHARS (val, SCHARS (val));
|
4004
|
665 }
|
20667
|
666 /* Copy a single-byte string to a multibyte string. */
|
|
667 else if (STRINGP (this) && STRINGP (val))
|
|
668 {
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
669 if (! NULL_INTERVAL_P (STRING_INTERVALS (this)))
|
25093
|
670 {
|
25094
|
671 textprops[num_textprops].argnum = argnum;
|
|
672 textprops[num_textprops].from = 0;
|
|
673 textprops[num_textprops++].to = toindex;
|
25093
|
674 }
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
675 toindex_byte += copy_text (SDATA (this),
|
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
676 SDATA (val) + toindex_byte,
|
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
677 SCHARS (this), 0, 1);
|
20667
|
678 toindex += thisleni;
|
|
679 }
|
20607
|
680 else
|
|
681 /* Copy element by element. */
|
|
682 while (1)
|
|
683 {
|
|
684 register Lisp_Object elt;
|
211
|
685
|
20607
|
686 /* Fetch next element of `this' arg into `elt', or break if
|
|
687 `this' is exhausted. */
|
|
688 if (NILP (this)) break;
|
|
689 if (CONSP (this))
|
25645
|
690 elt = XCAR (this), this = XCDR (this);
|
20814
|
691 else if (thisindex >= thisleni)
|
|
692 break;
|
|
693 else if (STRINGP (this))
|
20607
|
694 {
|
21029
|
695 int c;
|
20814
|
696 if (STRING_MULTIBYTE (this))
|
20607
|
697 {
|
29010
|
698 FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, this,
|
|
699 thisindex,
|
|
700 thisindex_byte);
|
20814
|
701 XSETFASTINT (elt, c);
|
|
702 }
|
|
703 else
|
|
704 {
|
58265
|
705 XSETFASTINT (elt, SREF (this, thisindex)); thisindex++;
|
23152
|
706 if (some_multibyte
|
88375
|
707 && XINT (elt) >= 0200
|
20814
|
708 && XINT (elt) < 0400)
|
20607
|
709 {
|
21029
|
710 c = unibyte_char_to_multibyte (XINT (elt));
|
20814
|
711 XSETINT (elt, c);
|
20607
|
712 }
|
|
713 }
|
20814
|
714 }
|
|
715 else if (BOOL_VECTOR_P (this))
|
|
716 {
|
|
717 int byte;
|
55161
beac72c0215f
(Fcopy_sequence, concat, internal_equal, Ffillarray, mapcar1): Use
Andreas Schwab <schwab@suse.de>
diff
changeset
|
718 byte = XBOOL_VECTOR (this)->data[thisindex / BOOL_VECTOR_BITS_PER_CHAR];
|
beac72c0215f
(Fcopy_sequence, concat, internal_equal, Ffillarray, mapcar1): Use
Andreas Schwab <schwab@suse.de>
diff
changeset
|
719 if (byte & (1 << (thisindex % BOOL_VECTOR_BITS_PER_CHAR)))
|
20814
|
720 elt = Qt;
|
20607
|
721 else
|
20814
|
722 elt = Qnil;
|
|
723 thisindex++;
|
20607
|
724 }
|
20814
|
725 else
|
91667
|
726 {
|
|
727 elt = AREF (this, thisindex);
|
|
728 thisindex++;
|
|
729 }
|
211
|
730
|
20607
|
731 /* Store this element into the result. */
|
|
732 if (toindex < 0)
|
|
733 {
|
39973
579177964efa
Avoid (most) uses of XCAR/XCDR as lvalues, for flexibility in experimenting
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
734 XSETCAR (tail, elt);
|
20607
|
735 prev = tail;
|
25645
|
736 tail = XCDR (tail);
|
20607
|
737 }
|
|
738 else if (VECTORP (val))
|
91667
|
739 {
|
|
740 ASET (val, toindex, elt);
|
|
741 toindex++;
|
|
742 }
|
20607
|
743 else
|
211
|
744 {
|
40656
|
745 CHECK_NUMBER (elt);
|
88375
|
746 if (some_multibyte)
|
89483
|
747 toindex_byte += CHAR_STRING (XINT (elt),
|
|
748 SDATA (val) + toindex_byte);
|
20607
|
749 else
|
89483
|
750 SSET (val, toindex_byte++, XINT (elt));
|
88375
|
751 toindex++;
|
211
|
752 }
|
20607
|
753 }
|
211
|
754 }
|
485
|
755 if (!NILP (prev))
|
39973
579177964efa
Avoid (most) uses of XCAR/XCDR as lvalues, for flexibility in experimenting
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
756 XSETCDR (prev, last_tail);
|
211
|
757
|
25094
|
758 if (num_textprops > 0)
|
25093
|
759 {
|
30024
|
760 Lisp_Object props;
|
35352
|
761 int last_to_end = -1;
|
30024
|
762
|
25094
|
763 for (argnum = 0; argnum < num_textprops; argnum++)
|
25093
|
764 {
|
25094
|
765 this = args[textprops[argnum].argnum];
|
30024
|
766 props = text_property_list (this,
|
|
767 make_number (0),
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
768 make_number (SCHARS (this)),
|
30024
|
769 Qnil);
|
|
770 /* If successive arguments have properites, be sure that the
|
|
771 value of `composition' property be the copy. */
|
35352
|
772 if (last_to_end == textprops[argnum].to)
|
30024
|
773 make_composition_value_copy (props);
|
|
774 add_text_properties_from_list (val, props,
|
|
775 make_number (textprops[argnum].to));
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
776 last_to_end = textprops[argnum].to + SCHARS (this);
|
25093
|
777 }
|
|
778 }
|
58623
|
779
|
|
780 SAFE_FREE ();
|
20004
|
781 return val;
|
211
|
782 }
|
|
783
|
20667
|
784 static Lisp_Object string_char_byte_cache_string;
|
91807
507bcfb4342c
* coding.c (coding_set_destination): Use BEG_BYTE rather than hardcoding 1.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
785 static EMACS_INT string_char_byte_cache_charpos;
|
507bcfb4342c
* coding.c (coding_set_destination): Use BEG_BYTE rather than hardcoding 1.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
786 static EMACS_INT string_char_byte_cache_bytepos;
|
20667
|
787
|
23424
|
788 void
|
|
789 clear_string_char_byte_cache ()
|
|
790 {
|
|
791 string_char_byte_cache_string = Qnil;
|
|
792 }
|
|
793
|
91807
507bcfb4342c
* coding.c (coding_set_destination): Use BEG_BYTE rather than hardcoding 1.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
794 /* Return the byte index corresponding to CHAR_INDEX in STRING. */
|
507bcfb4342c
* coding.c (coding_set_destination): Use BEG_BYTE rather than hardcoding 1.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
795
|
507bcfb4342c
* coding.c (coding_set_destination): Use BEG_BYTE rather than hardcoding 1.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
796 EMACS_INT
|
20607
|
797 string_char_to_byte (string, char_index)
|
|
798 Lisp_Object string;
|
91807
507bcfb4342c
* coding.c (coding_set_destination): Use BEG_BYTE rather than hardcoding 1.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
799 EMACS_INT char_index;
|
20607
|
800 {
|
91807
507bcfb4342c
* coding.c (coding_set_destination): Use BEG_BYTE rather than hardcoding 1.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
801 EMACS_INT i_byte;
|
507bcfb4342c
* coding.c (coding_set_destination): Use BEG_BYTE rather than hardcoding 1.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
802 EMACS_INT best_below, best_below_byte;
|
507bcfb4342c
* coding.c (coding_set_destination): Use BEG_BYTE rather than hardcoding 1.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
803 EMACS_INT best_above, best_above_byte;
|
20607
|
804
|
20667
|
805 best_below = best_below_byte = 0;
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
806 best_above = SCHARS (string);
|
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
807 best_above_byte = SBYTES (string);
|
53742
|
808 if (best_above == best_above_byte)
|
|
809 return char_index;
|
20667
|
810
|
|
811 if (EQ (string, string_char_byte_cache_string))
|
|
812 {
|
|
813 if (string_char_byte_cache_charpos < char_index)
|
|
814 {
|
|
815 best_below = string_char_byte_cache_charpos;
|
|
816 best_below_byte = string_char_byte_cache_bytepos;
|
|
817 }
|
|
818 else
|
|
819 {
|
|
820 best_above = string_char_byte_cache_charpos;
|
|
821 best_above_byte = string_char_byte_cache_bytepos;
|
|
822 }
|
|
823 }
|
|
824
|
|
825 if (char_index - best_below < best_above - char_index)
|
20607
|
826 {
|
89483
|
827 unsigned char *p = SDATA (string) + best_below_byte;
|
88375
|
828
|
20667
|
829 while (best_below < char_index)
|
|
830 {
|
88375
|
831 p += BYTES_BY_CHAR_HEAD (*p);
|
|
832 best_below++;
|
20667
|
833 }
|
89483
|
834 i_byte = p - SDATA (string);
|
20607
|
835 }
|
20667
|
836 else
|
|
837 {
|
89483
|
838 unsigned char *p = SDATA (string) + best_above_byte;
|
88375
|
839
|
20667
|
840 while (best_above > char_index)
|
|
841 {
|
88375
|
842 p--;
|
|
843 while (!CHAR_HEAD_P (*p)) p--;
|
20667
|
844 best_above--;
|
|
845 }
|
89483
|
846 i_byte = p - SDATA (string);
|
20667
|
847 }
|
|
848
|
|
849 string_char_byte_cache_bytepos = i_byte;
|
88375
|
850 string_char_byte_cache_charpos = char_index;
|
20667
|
851 string_char_byte_cache_string = string;
|
20607
|
852
|
|
853 return i_byte;
|
|
854 }
|
20667
|
855
|
20607
|
856 /* Return the character index corresponding to BYTE_INDEX in STRING. */
|
|
857
|
91807
507bcfb4342c
* coding.c (coding_set_destination): Use BEG_BYTE rather than hardcoding 1.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
858 EMACS_INT
|
20607
|
859 string_byte_to_char (string, byte_index)
|
|
860 Lisp_Object string;
|
91807
507bcfb4342c
* coding.c (coding_set_destination): Use BEG_BYTE rather than hardcoding 1.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
861 EMACS_INT byte_index;
|
20607
|
862 {
|
91807
507bcfb4342c
* coding.c (coding_set_destination): Use BEG_BYTE rather than hardcoding 1.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
863 EMACS_INT i, i_byte;
|
507bcfb4342c
* coding.c (coding_set_destination): Use BEG_BYTE rather than hardcoding 1.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
864 EMACS_INT best_below, best_below_byte;
|
507bcfb4342c
* coding.c (coding_set_destination): Use BEG_BYTE rather than hardcoding 1.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
865 EMACS_INT best_above, best_above_byte;
|
20607
|
866
|
20667
|
867 best_below = best_below_byte = 0;
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
868 best_above = SCHARS (string);
|
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
869 best_above_byte = SBYTES (string);
|
53742
|
870 if (best_above == best_above_byte)
|
|
871 return byte_index;
|
20667
|
872
|
|
873 if (EQ (string, string_char_byte_cache_string))
|
|
874 {
|
|
875 if (string_char_byte_cache_bytepos < byte_index)
|
|
876 {
|
|
877 best_below = string_char_byte_cache_charpos;
|
|
878 best_below_byte = string_char_byte_cache_bytepos;
|
|
879 }
|
|
880 else
|
|
881 {
|
|
882 best_above = string_char_byte_cache_charpos;
|
|
883 best_above_byte = string_char_byte_cache_bytepos;
|
|
884 }
|
|
885 }
|
|
886
|
|
887 if (byte_index - best_below_byte < best_above_byte - byte_index)
|
20607
|
888 {
|
89483
|
889 unsigned char *p = SDATA (string) + best_below_byte;
|
|
890 unsigned char *pend = SDATA (string) + byte_index;
|
88375
|
891
|
|
892 while (p < pend)
|
20667
|
893 {
|
88375
|
894 p += BYTES_BY_CHAR_HEAD (*p);
|
|
895 best_below++;
|
20667
|
896 }
|
|
897 i = best_below;
|
89483
|
898 i_byte = p - SDATA (string);
|
20607
|
899 }
|
20667
|
900 else
|
|
901 {
|
89483
|
902 unsigned char *p = SDATA (string) + best_above_byte;
|
|
903 unsigned char *pbeg = SDATA (string) + byte_index;
|
88375
|
904
|
|
905 while (p > pbeg)
|
20667
|
906 {
|
88375
|
907 p--;
|
|
908 while (!CHAR_HEAD_P (*p)) p--;
|
20667
|
909 best_above--;
|
|
910 }
|
|
911 i = best_above;
|
89483
|
912 i_byte = p - SDATA (string);
|
20667
|
913 }
|
|
914
|
|
915 string_char_byte_cache_bytepos = i_byte;
|
|
916 string_char_byte_cache_charpos = i;
|
|
917 string_char_byte_cache_string = string;
|
20607
|
918
|
|
919 return i;
|
|
920 }
|
20667
|
921
|
88980
|
922 /* Convert STRING to a multibyte string. */
|
20607
|
923
|
|
924 Lisp_Object
|
|
925 string_make_multibyte (string)
|
|
926 Lisp_Object string;
|
|
927 {
|
|
928 unsigned char *buf;
|
91807
507bcfb4342c
* coding.c (coding_set_destination): Use BEG_BYTE rather than hardcoding 1.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
929 EMACS_INT nbytes;
|
56195
|
930 Lisp_Object ret;
|
|
931 USE_SAFE_ALLOCA;
|
20607
|
932
|
|
933 if (STRING_MULTIBYTE (string))
|
|
934 return string;
|
|
935
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
936 nbytes = count_size_as_multibyte (SDATA (string),
|
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
937 SCHARS (string));
|
20813
|
938 /* If all the chars are ASCII, they won't need any more bytes
|
|
939 once converted. In that case, we can return STRING itself. */
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
940 if (nbytes == SBYTES (string))
|
20813
|
941 return string;
|
|
942
|
56195
|
943 SAFE_ALLOCA (buf, unsigned char *, nbytes);
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
944 copy_text (SDATA (string), buf, SBYTES (string),
|
20607
|
945 0, 1);
|
|
946
|
56195
|
947 ret = make_multibyte_string (buf, SCHARS (string), nbytes);
|
57726
|
948 SAFE_FREE ();
|
56195
|
949
|
|
950 return ret;
|
20607
|
951 }
|
|
952
|
49656
|
953
|
89483
|
954 /* Convert STRING (if unibyte) to a multibyte string without changing
|
|
955 the number of characters. Characters 0200 trough 0237 are
|
|
956 converted to eight-bit characters. */
|
49656
|
957
|
|
958 Lisp_Object
|
|
959 string_to_multibyte (string)
|
|
960 Lisp_Object string;
|
|
961 {
|
|
962 unsigned char *buf;
|
91807
507bcfb4342c
* coding.c (coding_set_destination): Use BEG_BYTE rather than hardcoding 1.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
963 EMACS_INT nbytes;
|
56195
|
964 Lisp_Object ret;
|
|
965 USE_SAFE_ALLOCA;
|
49656
|
966
|
|
967 if (STRING_MULTIBYTE (string))
|
|
968 return string;
|
|
969
|
|
970 nbytes = parse_str_to_multibyte (SDATA (string), SBYTES (string));
|
89483
|
971 /* If all the chars are ASCII, they won't need any more bytes once
|
|
972 converted. */
|
49656
|
973 if (nbytes == SBYTES (string))
|
49815
|
974 return make_multibyte_string (SDATA (string), nbytes, nbytes);
|
49656
|
975
|
56195
|
976 SAFE_ALLOCA (buf, unsigned char *, nbytes);
|
49656
|
977 bcopy (SDATA (string), buf, SBYTES (string));
|
|
978 str_to_multibyte (buf, nbytes, SBYTES (string));
|
|
979
|
56195
|
980 ret = make_multibyte_string (buf, SCHARS (string), nbytes);
|
57726
|
981 SAFE_FREE ();
|
56195
|
982
|
|
983 return ret;
|
49656
|
984 }
|
|
985
|
|
986
|
20607
|
987 /* Convert STRING to a single-byte string. */
|
|
988
|
|
989 Lisp_Object
|
|
990 string_make_unibyte (string)
|
|
991 Lisp_Object string;
|
|
992 {
|
56195
|
993 int nchars;
|
20607
|
994 unsigned char *buf;
|
56147
6b858fb89033
* fns.c (string_to_multibyte): Use xmalloc/xfree instead of alloca.
Jan Djärv <jan.h.d@swipnet.se>
diff
changeset
|
995 Lisp_Object ret;
|
56195
|
996 USE_SAFE_ALLOCA;
|
20607
|
997
|
|
998 if (! STRING_MULTIBYTE (string))
|
|
999 return string;
|
|
1000
|
56195
|
1001 nchars = SCHARS (string);
|
|
1002
|
|
1003 SAFE_ALLOCA (buf, unsigned char *, nchars);
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1004 copy_text (SDATA (string), buf, SBYTES (string),
|
20607
|
1005 1, 0);
|
|
1006
|
56195
|
1007 ret = make_unibyte_string (buf, nchars);
|
57726
|
1008 SAFE_FREE ();
|
56147
6b858fb89033
* fns.c (string_to_multibyte): Use xmalloc/xfree instead of alloca.
Jan Djärv <jan.h.d@swipnet.se>
diff
changeset
|
1009
|
6b858fb89033
* fns.c (string_to_multibyte): Use xmalloc/xfree instead of alloca.
Jan Djärv <jan.h.d@swipnet.se>
diff
changeset
|
1010 return ret;
|
20607
|
1011 }
|
20667
|
1012
|
|
1013 DEFUN ("string-make-multibyte", Fstring_make_multibyte, Sstring_make_multibyte,
|
|
1014 1, 1, 0,
|
39977
|
1015 doc: /* Return the multibyte equivalent of STRING.
|
53255
|
1016 If STRING is unibyte and contains non-ASCII characters, the function
|
|
1017 `unibyte-char-to-multibyte' is used to convert each unibyte character
|
|
1018 to a multibyte character. In this case, the returned string is a
|
|
1019 newly created string with no text properties. If STRING is multibyte
|
|
1020 or entirely ASCII, it is returned unchanged. In particular, when
|
|
1021 STRING is unibyte and entirely ASCII, the returned string is unibyte.
|
|
1022 \(When the characters are all ASCII, Emacs primitives will treat the
|
|
1023 string the same way whether it is unibyte or multibyte.) */)
|
39977
|
1024 (string)
|
20667
|
1025 Lisp_Object string;
|
|
1026 {
|
40656
|
1027 CHECK_STRING (string);
|
22165
|
1028
|
20667
|
1029 return string_make_multibyte (string);
|
|
1030 }
|
|
1031
|
|
1032 DEFUN ("string-make-unibyte", Fstring_make_unibyte, Sstring_make_unibyte,
|
|
1033 1, 1, 0,
|
39977
|
1034 doc: /* Return the unibyte equivalent of STRING.
|
45650
|
1035 Multibyte character codes are converted to unibyte according to
|
|
1036 `nonascii-translation-table' or, if that is nil, `nonascii-insert-offset'.
|
|
1037 If the lookup in the translation table fails, this function takes just
|
73926
21f6be2e8ecb
(Frandom, Flength, Fsafe_length, Fstring_bytes, Fstring_equal, Fcompare_strings,
Juanma Barranquero <lekktu@gmail.com>
diff
changeset
|
1038 the low 8 bits of each character. */)
|
39977
|
1039 (string)
|
20667
|
1040 Lisp_Object string;
|
|
1041 {
|
40656
|
1042 CHECK_STRING (string);
|
22165
|
1043
|
20667
|
1044 return string_make_unibyte (string);
|
|
1045 }
|
20813
|
1046
|
|
1047 DEFUN ("string-as-unibyte", Fstring_as_unibyte, Sstring_as_unibyte,
|
|
1048 1, 1, 0,
|
39977
|
1049 doc: /* Return a unibyte string with the same individual bytes as STRING.
|
39899
|
1050 If STRING is unibyte, the result is STRING itself.
|
|
1051 Otherwise it is a newly created string, with no text properties.
|
|
1052 If STRING is multibyte and contains a character of charset
|
89909
|
1053 `eight-bit', it is converted to the corresponding single byte. */)
|
39977
|
1054 (string)
|
20813
|
1055 Lisp_Object string;
|
|
1056 {
|
40656
|
1057 CHECK_STRING (string);
|
22165
|
1058
|
20813
|
1059 if (STRING_MULTIBYTE (string))
|
|
1060 {
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1061 int bytes = SBYTES (string);
|
29010
|
1062 unsigned char *str = (unsigned char *) xmalloc (bytes);
|
|
1063
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1064 bcopy (SDATA (string), str, bytes);
|
29010
|
1065 bytes = str_as_unibyte (str, bytes);
|
|
1066 string = make_unibyte_string (str, bytes);
|
|
1067 xfree (str);
|
20813
|
1068 }
|
|
1069 return string;
|
|
1070 }
|
|
1071
|
|
1072 DEFUN ("string-as-multibyte", Fstring_as_multibyte, Sstring_as_multibyte,
|
|
1073 1, 1, 0,
|
39977
|
1074 doc: /* Return a multibyte string with the same individual bytes as STRING.
|
39899
|
1075 If STRING is multibyte, the result is STRING itself.
|
|
1076 Otherwise it is a newly created string, with no text properties.
|
89203
|
1077
|
39899
|
1078 If STRING is unibyte and contains an individual 8-bit byte (i.e. not
|
89203
|
1079 part of a correct utf-8 sequence), it is converted to the corresponding
|
|
1080 multibyte character of charset `eight-bit'.
|
90144
|
1081 See also `string-to-multibyte'.
|
|
1082
|
61433
74a256d5f3ec
(Fstring_as_multibyte, Fstring_to_multibyte): Docstring fixes.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
1083 Beware, this often doesn't really do what you think it does.
|
90144
|
1084 It is similar to (decode-coding-string STRING 'utf-8-emacs).
|
61433
74a256d5f3ec
(Fstring_as_multibyte, Fstring_to_multibyte): Docstring fixes.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
1085 If you're not sure, whether to use `string-as-multibyte' or
|
90144
|
1086 `string-to-multibyte', use `string-to-multibyte'. */)
|
39977
|
1087 (string)
|
20813
|
1088 Lisp_Object string;
|
|
1089 {
|
40656
|
1090 CHECK_STRING (string);
|
22165
|
1091
|
20813
|
1092 if (! STRING_MULTIBYTE (string))
|
|
1093 {
|
29010
|
1094 Lisp_Object new_string;
|
|
1095 int nchars, nbytes;
|
|
1096
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1097 parse_str_as_multibyte (SDATA (string),
|
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1098 SBYTES (string),
|
29010
|
1099 &nchars, &nbytes);
|
|
1100 new_string = make_uninit_multibyte_string (nchars, nbytes);
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1101 bcopy (SDATA (string), SDATA (new_string),
|
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1102 SBYTES (string));
|
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1103 if (nbytes != SBYTES (string))
|
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1104 str_as_multibyte (SDATA (new_string), nbytes,
|
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1105 SBYTES (string), NULL);
|
29010
|
1106 string = new_string;
|
46379
|
1107 STRING_SET_INTERVALS (string, NULL_INTERVAL);
|
20813
|
1108 }
|
|
1109 return string;
|
|
1110 }
|
49656
|
1111
|
|
1112 DEFUN ("string-to-multibyte", Fstring_to_multibyte, Sstring_to_multibyte,
|
|
1113 1, 1, 0,
|
|
1114 doc: /* Return a multibyte string with the same individual chars as STRING.
|
49674
|
1115 If STRING is multibyte, the result is STRING itself.
|
49656
|
1116 Otherwise it is a newly created string, with no text properties.
|
88953
|
1117
|
|
1118 If STRING is unibyte and contains an 8-bit byte, it is converted to
|
89203
|
1119 the corresponding multibyte character of charset `eight-bit'.
|
|
1120
|
|
1121 This differs from `string-as-multibyte' by converting each byte of a correct
|
|
1122 utf-8 sequence to an eight-bit character, not just bytes that don't form a
|
|
1123 correct sequence. */)
|
49656
|
1124 (string)
|
|
1125 Lisp_Object string;
|
|
1126 {
|
|
1127 CHECK_STRING (string);
|
|
1128
|
|
1129 return string_to_multibyte (string);
|
|
1130 }
|
|
1131
|
96248
|
1132 DEFUN ("string-to-unibyte", Fstring_to_unibyte, Sstring_to_unibyte,
|
96502
|
1133 1, 1, 0,
|
96248
|
1134 doc: /* Return a unibyte string with the same individual chars as STRING.
|
|
1135 If STRING is unibyte, the result is STRING itself.
|
|
1136 Otherwise it is a newly created string, with no text properties,
|
|
1137 where each `eight-bit' character is converted to the corresponding byte.
|
|
1138 If STRING contains a non-ASCII, non-`eight-bit' character,
|
96502
|
1139 an error is signaled. */)
|
|
1140 (string)
|
|
1141 Lisp_Object string;
|
96248
|
1142 {
|
|
1143 CHECK_STRING (string);
|
|
1144
|
|
1145 if (STRING_MULTIBYTE (string))
|
|
1146 {
|
|
1147 EMACS_INT chars = SCHARS (string);
|
|
1148 unsigned char *str = (unsigned char *) xmalloc (chars);
|
96502
|
1149 EMACS_INT converted = str_to_unibyte (SDATA (string), str, chars, 0);
|
|
1150
|
96248
|
1151 if (converted < chars)
|
|
1152 error ("Can't convert the %dth character to unibyte", converted);
|
|
1153 string = make_unibyte_string (str, chars);
|
|
1154 xfree (str);
|
|
1155 }
|
|
1156 return string;
|
|
1157 }
|
|
1158
|
20607
|
1159
|
211
|
1160 DEFUN ("copy-alist", Fcopy_alist, Scopy_alist, 1, 1, 0,
|
39977
|
1161 doc: /* Return a copy of ALIST.
|
39899
|
1162 This is an alist which represents the same mapping from objects to objects,
|
|
1163 but does not share the alist structure with ALIST.
|
|
1164 The objects mapped (cars and cdrs of elements of the alist)
|
|
1165 are shared, however.
|
39977
|
1166 Elements of ALIST that are not conses are also shared. */)
|
|
1167 (alist)
|
211
|
1168 Lisp_Object alist;
|
|
1169 {
|
|
1170 register Lisp_Object tem;
|
|
1171
|
40656
|
1172 CHECK_LIST (alist);
|
485
|
1173 if (NILP (alist))
|
211
|
1174 return alist;
|
|
1175 alist = concat (1, &alist, Lisp_Cons, 0);
|
25645
|
1176 for (tem = alist; CONSP (tem); tem = XCDR (tem))
|
211
|
1177 {
|
|
1178 register Lisp_Object car;
|
25645
|
1179 car = XCAR (tem);
|
211
|
1180
|
|
1181 if (CONSP (car))
|
39973
579177964efa
Avoid (most) uses of XCAR/XCDR as lvalues, for flexibility in experimenting
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1182 XSETCAR (tem, Fcons (XCAR (car), XCDR (car)));
|
211
|
1183 }
|
|
1184 return alist;
|
|
1185 }
|
|
1186
|
|
1187 DEFUN ("substring", Fsubstring, Ssubstring, 2, 3, 0,
|
101287
|
1188 doc: /* Return a new string whose contents are a substring of STRING.
|
|
1189 The returned string consists of the characters between index FROM
|
|
1190 \(inclusive) and index TO (exclusive) of STRING. FROM and TO are
|
|
1191 zero-indexed: 0 means the first character of STRING. Negative values
|
|
1192 are counted from the end of STRING. If TO is nil, the substring runs
|
|
1193 to the end of STRING.
|
|
1194
|
|
1195 The STRING argument may also be a vector. In that case, the return
|
|
1196 value is a new vector that contains the elements between index FROM
|
|
1197 \(inclusive) and index TO (exclusive) of that vector argument. */)
|
39977
|
1198 (string, from, to)
|
211
|
1199 Lisp_Object string;
|
|
1200 register Lisp_Object from, to;
|
|
1201 {
|
4004
|
1202 Lisp_Object res;
|
15966
|
1203 int size;
|
31533
|
1204 int size_byte = 0;
|
20607
|
1205 int from_char, to_char;
|
31533
|
1206 int from_byte = 0, to_byte = 0;
|
4004
|
1207
|
71833
|
1208 CHECK_VECTOR_OR_STRING (string);
|
40656
|
1209 CHECK_NUMBER (from);
|
15966
|
1210
|
|
1211 if (STRINGP (string))
|
20607
|
1212 {
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1213 size = SCHARS (string);
|
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1214 size_byte = SBYTES (string);
|
20607
|
1215 }
|
15966
|
1216 else
|
74163
|
1217 size = ASIZE (string);
|
15966
|
1218
|
485
|
1219 if (NILP (to))
|
20607
|
1220 {
|
|
1221 to_char = size;
|
|
1222 to_byte = size_byte;
|
|
1223 }
|
211
|
1224 else
|
20607
|
1225 {
|
40656
|
1226 CHECK_NUMBER (to);
|
20607
|
1227
|
|
1228 to_char = XINT (to);
|
|
1229 if (to_char < 0)
|
|
1230 to_char += size;
|
211
|
1231
|
20607
|
1232 if (STRINGP (string))
|
|
1233 to_byte = string_char_to_byte (string, to_char);
|
|
1234 }
|
|
1235
|
|
1236 from_char = XINT (from);
|
|
1237 if (from_char < 0)
|
|
1238 from_char += size;
|
|
1239 if (STRINGP (string))
|
|
1240 from_byte = string_char_to_byte (string, from_char);
|
|
1241
|
|
1242 if (!(0 <= from_char && from_char <= to_char && to_char <= size))
|
|
1243 args_out_of_range_3 (string, make_number (from_char),
|
|
1244 make_number (to_char));
|
211
|
1245
|
15966
|
1246 if (STRINGP (string))
|
|
1247 {
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1248 res = make_specified_string (SDATA (string) + from_byte,
|
21260
|
1249 to_char - from_char, to_byte - from_byte,
|
|
1250 STRING_MULTIBYTE (string));
|
21523
|
1251 copy_text_properties (make_number (from_char), make_number (to_char),
|
|
1252 string, make_number (0), res, Qnil);
|
20607
|
1253 }
|
|
1254 else
|
74163
|
1255 res = Fvector (to_char - from_char, &AREF (string, from_char));
|
20607
|
1256
|
|
1257 return res;
|
|
1258 }
|
|
1259
|
44159
|
1260
|
|
1261 DEFUN ("substring-no-properties", Fsubstring_no_properties, Ssubstring_no_properties, 1, 3, 0,
|
|
1262 doc: /* Return a substring of STRING, without text properties.
|
|
1263 It starts at index FROM and ending before TO.
|
|
1264 TO may be nil or omitted; then the substring runs to the end of STRING.
|
|
1265 If FROM is nil or omitted, the substring starts at the beginning of STRING.
|
|
1266 If FROM or TO is negative, it counts from the end.
|
|
1267
|
|
1268 With one argument, just copy STRING without its properties. */)
|
|
1269 (string, from, to)
|
|
1270 Lisp_Object string;
|
|
1271 register Lisp_Object from, to;
|
|
1272 {
|
|
1273 int size, size_byte;
|
|
1274 int from_char, to_char;
|
|
1275 int from_byte, to_byte;
|
|
1276
|
|
1277 CHECK_STRING (string);
|
|
1278
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1279 size = SCHARS (string);
|
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1280 size_byte = SBYTES (string);
|
44159
|
1281
|
|
1282 if (NILP (from))
|
|
1283 from_char = from_byte = 0;
|
|
1284 else
|
|
1285 {
|
|
1286 CHECK_NUMBER (from);
|
|
1287 from_char = XINT (from);
|
|
1288 if (from_char < 0)
|
|
1289 from_char += size;
|
|
1290
|
|
1291 from_byte = string_char_to_byte (string, from_char);
|
|
1292 }
|
|
1293
|
|
1294 if (NILP (to))
|
|
1295 {
|
|
1296 to_char = size;
|
|
1297 to_byte = size_byte;
|
|
1298 }
|
|
1299 else
|
|
1300 {
|
|
1301 CHECK_NUMBER (to);
|
|
1302
|
|
1303 to_char = XINT (to);
|
|
1304 if (to_char < 0)
|
|
1305 to_char += size;
|
|
1306
|
|
1307 to_byte = string_char_to_byte (string, to_char);
|
|
1308 }
|
|
1309
|
|
1310 if (!(0 <= from_char && from_char <= to_char && to_char <= size))
|
|
1311 args_out_of_range_3 (string, make_number (from_char),
|
|
1312 make_number (to_char));
|
|
1313
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1314 return make_specified_string (SDATA (string) + from_byte,
|
44159
|
1315 to_char - from_char, to_byte - from_byte,
|
|
1316 STRING_MULTIBYTE (string));
|
|
1317 }
|
|
1318
|
20607
|
1319 /* Extract a substring of STRING, giving start and end positions
|
|
1320 both in characters and in bytes. */
|
|
1321
|
|
1322 Lisp_Object
|
|
1323 substring_both (string, from, from_byte, to, to_byte)
|
|
1324 Lisp_Object string;
|
|
1325 int from, from_byte, to, to_byte;
|
|
1326 {
|
|
1327 Lisp_Object res;
|
|
1328 int size;
|
|
1329 int size_byte;
|
|
1330
|
71833
|
1331 CHECK_VECTOR_OR_STRING (string);
|
20607
|
1332
|
|
1333 if (STRINGP (string))
|
|
1334 {
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1335 size = SCHARS (string);
|
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1336 size_byte = SBYTES (string);
|
20607
|
1337 }
|
|
1338 else
|
74163
|
1339 size = ASIZE (string);
|
20607
|
1340
|
|
1341 if (!(0 <= from && from <= to && to <= size))
|
|
1342 args_out_of_range_3 (string, make_number (from), make_number (to));
|
|
1343
|
|
1344 if (STRINGP (string))
|
|
1345 {
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1346 res = make_specified_string (SDATA (string) + from_byte,
|
21260
|
1347 to - from, to_byte - from_byte,
|
|
1348 STRING_MULTIBYTE (string));
|
21523
|
1349 copy_text_properties (make_number (from), make_number (to),
|
|
1350 string, make_number (0), res, Qnil);
|
15966
|
1351 }
|
|
1352 else
|
74169
|
1353 res = Fvector (to - from, &AREF (string, from));
|
20004
|
1354
|
4004
|
1355 return res;
|
211
|
1356 }
|
|
1357
|
|
1358 DEFUN ("nthcdr", Fnthcdr, Snthcdr, 2, 2, 0,
|
39977
|
1359 doc: /* Take cdr N times on LIST, returns the result. */)
|
|
1360 (n, list)
|
211
|
1361 Lisp_Object n;
|
|
1362 register Lisp_Object list;
|
|
1363 {
|
|
1364 register int i, num;
|
40656
|
1365 CHECK_NUMBER (n);
|
211
|
1366 num = XINT (n);
|
485
|
1367 for (i = 0; i < num && !NILP (list); i++)
|
211
|
1368 {
|
|
1369 QUIT;
|
71833
|
1370 CHECK_LIST_CONS (list, list);
|
26596
|
1371 list = XCDR (list);
|
211
|
1372 }
|
|
1373 return list;
|
|
1374 }
|
|
1375
|
|
1376 DEFUN ("nth", Fnth, Snth, 2, 2, 0,
|
39977
|
1377 doc: /* Return the Nth element of LIST.
|
|
1378 N counts from zero. If LIST is not that long, nil is returned. */)
|
|
1379 (n, list)
|
211
|
1380 Lisp_Object n, list;
|
|
1381 {
|
|
1382 return Fcar (Fnthcdr (n, list));
|
|
1383 }
|
|
1384
|
|
1385 DEFUN ("elt", Felt, Selt, 2, 2, 0,
|
39977
|
1386 doc: /* Return element of SEQUENCE at index N. */)
|
|
1387 (sequence, n)
|
14091
34911b128a47
(Frandom, Flength, Felt, Fsort, Fchar_table_subtype, Fchar_table_parent,
Erik Naggum <erik@naggum.no>
diff
changeset
|
1388 register Lisp_Object sequence, n;
|
211
|
1389 {
|
40656
|
1390 CHECK_NUMBER (n);
|
71833
|
1391 if (CONSP (sequence) || NILP (sequence))
|
|
1392 return Fcar (Fnthcdr (n, sequence));
|
|
1393
|
|
1394 /* Faref signals a "not array" error, so check here. */
|
|
1395 CHECK_ARRAY (sequence, Qsequencep);
|
|
1396 return Faref (sequence, n);
|
211
|
1397 }
|
|
1398
|
|
1399 DEFUN ("member", Fmember, Smember, 2, 2, 0,
|
39977
|
1400 doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'.
|
|
1401 The value is actually the tail of LIST whose car is ELT. */)
|
|
1402 (elt, list)
|
211
|
1403 register Lisp_Object elt;
|
|
1404 Lisp_Object list;
|
|
1405 {
|
|
1406 register Lisp_Object tail;
|
85330
|
1407 for (tail = list; CONSP (tail); tail = XCDR (tail))
|
211
|
1408 {
|
|
1409 register Lisp_Object tem;
|
71833
|
1410 CHECK_LIST_CONS (tail, list);
|
26596
|
1411 tem = XCAR (tail);
|
485
|
1412 if (! NILP (Fequal (elt, tem)))
|
211
|
1413 return tail;
|
|
1414 QUIT;
|
|
1415 }
|
|
1416 return Qnil;
|
|
1417 }
|
|
1418
|
|
1419 DEFUN ("memq", Fmemq, Smemq, 2, 2, 0,
|
73029
|
1420 doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `eq'.
|
|
1421 The value is actually the tail of LIST whose car is ELT. */)
|
39977
|
1422 (elt, list)
|
73029
|
1423 register Lisp_Object elt, list;
|
211
|
1424 {
|
26230
|
1425 while (1)
|
211
|
1426 {
|
26230
|
1427 if (!CONSP (list) || EQ (XCAR (list), elt))
|
|
1428 break;
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
1429
|
26230
|
1430 list = XCDR (list);
|
|
1431 if (!CONSP (list) || EQ (XCAR (list), elt))
|
|
1432 break;
|
|
1433
|
|
1434 list = XCDR (list);
|
|
1435 if (!CONSP (list) || EQ (XCAR (list), elt))
|
|
1436 break;
|
|
1437
|
|
1438 list = XCDR (list);
|
211
|
1439 QUIT;
|
|
1440 }
|
26230
|
1441
|
71833
|
1442 CHECK_LIST (list);
|
26230
|
1443 return list;
|
211
|
1444 }
|
|
1445
|
73029
|
1446 DEFUN ("memql", Fmemql, Smemql, 2, 2, 0,
|
|
1447 doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `eql'.
|
|
1448 The value is actually the tail of LIST whose car is ELT. */)
|
|
1449 (elt, list)
|
|
1450 register Lisp_Object elt;
|
|
1451 Lisp_Object list;
|
|
1452 {
|
|
1453 register Lisp_Object tail;
|
|
1454
|
|
1455 if (!FLOATP (elt))
|
|
1456 return Fmemq (elt, list);
|
|
1457
|
85330
|
1458 for (tail = list; CONSP (tail); tail = XCDR (tail))
|
73029
|
1459 {
|
|
1460 register Lisp_Object tem;
|
|
1461 CHECK_LIST_CONS (tail, list);
|
|
1462 tem = XCAR (tail);
|
|
1463 if (FLOATP (tem) && internal_equal (elt, tem, 0, 0))
|
|
1464 return tail;
|
|
1465 QUIT;
|
|
1466 }
|
|
1467 return Qnil;
|
|
1468 }
|
|
1469
|
211
|
1470 DEFUN ("assq", Fassq, Sassq, 2, 2, 0,
|
39977
|
1471 doc: /* Return non-nil if KEY is `eq' to the car of an element of LIST.
|
53115
|
1472 The value is actually the first element of LIST whose car is KEY.
|
39977
|
1473 Elements of LIST that are not conses are ignored. */)
|
|
1474 (key, list)
|
26230
|
1475 Lisp_Object key, list;
|
211
|
1476 {
|
26230
|
1477 while (1)
|
211
|
1478 {
|
26230
|
1479 if (!CONSP (list)
|
|
1480 || (CONSP (XCAR (list))
|
|
1481 && EQ (XCAR (XCAR (list)), key)))
|
|
1482 break;
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
1483
|
26230
|
1484 list = XCDR (list);
|
|
1485 if (!CONSP (list)
|
|
1486 || (CONSP (XCAR (list))
|
|
1487 && EQ (XCAR (XCAR (list)), key)))
|
|
1488 break;
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
1489
|
26230
|
1490 list = XCDR (list);
|
|
1491 if (!CONSP (list)
|
|
1492 || (CONSP (XCAR (list))
|
|
1493 && EQ (XCAR (XCAR (list)), key)))
|
|
1494 break;
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
1495
|
26230
|
1496 list = XCDR (list);
|
211
|
1497 QUIT;
|
|
1498 }
|
26230
|
1499
|
71833
|
1500 return CAR (list);
|
211
|
1501 }
|
|
1502
|
|
1503 /* Like Fassq but never report an error and do not allow quits.
|
|
1504 Use only on lists known never to be circular. */
|
|
1505
|
|
1506 Lisp_Object
|
|
1507 assq_no_quit (key, list)
|
26230
|
1508 Lisp_Object key, list;
|
211
|
1509 {
|
26230
|
1510 while (CONSP (list)
|
|
1511 && (!CONSP (XCAR (list))
|
|
1512 || !EQ (XCAR (XCAR (list)), key)))
|
|
1513 list = XCDR (list);
|
|
1514
|
71833
|
1515 return CAR_SAFE (list);
|
211
|
1516 }
|
|
1517
|
|
1518 DEFUN ("assoc", Fassoc, Sassoc, 2, 2, 0,
|
39977
|
1519 doc: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
|
53115
|
1520 The value is actually the first element of LIST whose car equals KEY. */)
|
54994
|
1521 (key, list)
|
26230
|
1522 Lisp_Object key, list;
|
211
|
1523 {
|
71833
|
1524 Lisp_Object car;
|
26230
|
1525
|
|
1526 while (1)
|
211
|
1527 {
|
26230
|
1528 if (!CONSP (list)
|
|
1529 || (CONSP (XCAR (list))
|
|
1530 && (car = XCAR (XCAR (list)),
|
|
1531 EQ (car, key) || !NILP (Fequal (car, key)))))
|
|
1532 break;
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
1533
|
26230
|
1534 list = XCDR (list);
|
|
1535 if (!CONSP (list)
|
|
1536 || (CONSP (XCAR (list))
|
|
1537 && (car = XCAR (XCAR (list)),
|
|
1538 EQ (car, key) || !NILP (Fequal (car, key)))))
|
|
1539 break;
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
1540
|
26230
|
1541 list = XCDR (list);
|
|
1542 if (!CONSP (list)
|
|
1543 || (CONSP (XCAR (list))
|
|
1544 && (car = XCAR (XCAR (list)),
|
|
1545 EQ (car, key) || !NILP (Fequal (car, key)))))
|
|
1546 break;
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
1547
|
26230
|
1548 list = XCDR (list);
|
211
|
1549 QUIT;
|
|
1550 }
|
26230
|
1551
|
71833
|
1552 return CAR (list);
|
211
|
1553 }
|
|
1554
|
90408
|
1555 /* Like Fassoc but never report an error and do not allow quits.
|
|
1556 Use only on lists known never to be circular. */
|
|
1557
|
|
1558 Lisp_Object
|
|
1559 assoc_no_quit (key, list)
|
|
1560 Lisp_Object key, list;
|
|
1561 {
|
|
1562 while (CONSP (list)
|
|
1563 && (!CONSP (XCAR (list))
|
|
1564 || (!EQ (XCAR (XCAR (list)), key)
|
|
1565 && NILP (Fequal (XCAR (XCAR (list)), key)))))
|
|
1566 list = XCDR (list);
|
|
1567
|
|
1568 return CONSP (list) ? XCAR (list) : Qnil;
|
|
1569 }
|
|
1570
|
211
|
1571 DEFUN ("rassq", Frassq, Srassq, 2, 2, 0,
|
39977
|
1572 doc: /* Return non-nil if KEY is `eq' to the cdr of an element of LIST.
|
53115
|
1573 The value is actually the first element of LIST whose cdr is KEY. */)
|
39977
|
1574 (key, list)
|
211
|
1575 register Lisp_Object key;
|
|
1576 Lisp_Object list;
|
|
1577 {
|
26230
|
1578 while (1)
|
211
|
1579 {
|
26230
|
1580 if (!CONSP (list)
|
|
1581 || (CONSP (XCAR (list))
|
|
1582 && EQ (XCDR (XCAR (list)), key)))
|
|
1583 break;
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
1584
|
26230
|
1585 list = XCDR (list);
|
|
1586 if (!CONSP (list)
|
|
1587 || (CONSP (XCAR (list))
|
|
1588 && EQ (XCDR (XCAR (list)), key)))
|
|
1589 break;
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
1590
|
26230
|
1591 list = XCDR (list);
|
|
1592 if (!CONSP (list)
|
|
1593 || (CONSP (XCAR (list))
|
|
1594 && EQ (XCDR (XCAR (list)), key)))
|
|
1595 break;
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
1596
|
26230
|
1597 list = XCDR (list);
|
211
|
1598 QUIT;
|
|
1599 }
|
26230
|
1600
|
71833
|
1601 return CAR (list);
|
211
|
1602 }
|
10588
|
1603
|
|
1604 DEFUN ("rassoc", Frassoc, Srassoc, 2, 2, 0,
|
39977
|
1605 doc: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
|
53115
|
1606 The value is actually the first element of LIST whose cdr equals KEY. */)
|
39977
|
1607 (key, list)
|
26230
|
1608 Lisp_Object key, list;
|
10588
|
1609 {
|
71833
|
1610 Lisp_Object cdr;
|
26230
|
1611
|
|
1612 while (1)
|
10588
|
1613 {
|
26230
|
1614 if (!CONSP (list)
|
|
1615 || (CONSP (XCAR (list))
|
|
1616 && (cdr = XCDR (XCAR (list)),
|
|
1617 EQ (cdr, key) || !NILP (Fequal (cdr, key)))))
|
|
1618 break;
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
1619
|
26230
|
1620 list = XCDR (list);
|
|
1621 if (!CONSP (list)
|
|
1622 || (CONSP (XCAR (list))
|
|
1623 && (cdr = XCDR (XCAR (list)),
|
|
1624 EQ (cdr, key) || !NILP (Fequal (cdr, key)))))
|
|
1625 break;
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
1626
|
26230
|
1627 list = XCDR (list);
|
|
1628 if (!CONSP (list)
|
|
1629 || (CONSP (XCAR (list))
|
|
1630 && (cdr = XCDR (XCAR (list)),
|
|
1631 EQ (cdr, key) || !NILP (Fequal (cdr, key)))))
|
|
1632 break;
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
1633
|
26230
|
1634 list = XCDR (list);
|
10588
|
1635 QUIT;
|
|
1636 }
|
26230
|
1637
|
71833
|
1638 return CAR (list);
|
10588
|
1639 }
|
211
|
1640
|
|
1641 DEFUN ("delq", Fdelq, Sdelq, 2, 2, 0,
|
39977
|
1642 doc: /* Delete by side effect any occurrences of ELT as a member of LIST.
|
39899
|
1643 The modified LIST is returned. Comparison is done with `eq'.
|
|
1644 If the first member of LIST is ELT, there is no way to remove it by side effect;
|
|
1645 therefore, write `(setq foo (delq element foo))'
|
39977
|
1646 to be sure of changing the value of `foo'. */)
|
|
1647 (elt, list)
|
211
|
1648 register Lisp_Object elt;
|
|
1649 Lisp_Object list;
|
|
1650 {
|
|
1651 register Lisp_Object tail, prev;
|
|
1652 register Lisp_Object tem;
|
|
1653
|
|
1654 tail = list;
|
|
1655 prev = Qnil;
|
485
|
1656 while (!NILP (tail))
|
211
|
1657 {
|
71833
|
1658 CHECK_LIST_CONS (tail, list);
|
26596
|
1659 tem = XCAR (tail);
|
211
|
1660 if (EQ (elt, tem))
|
|
1661 {
|
485
|
1662 if (NILP (prev))
|
25645
|
1663 list = XCDR (tail);
|
211
|
1664 else
|
25645
|
1665 Fsetcdr (prev, XCDR (tail));
|
211
|
1666 }
|
|
1667 else
|
|
1668 prev = tail;
|
25645
|
1669 tail = XCDR (tail);
|
211
|
1670 QUIT;
|
|
1671 }
|
|
1672 return list;
|
|
1673 }
|
|
1674
|
414
|
1675 DEFUN ("delete", Fdelete, Sdelete, 2, 2, 0,
|
39977
|
1676 doc: /* Delete by side effect any occurrences of ELT as a member of SEQ.
|
39899
|
1677 SEQ must be a list, a vector, or a string.
|
|
1678 The modified SEQ is returned. Comparison is done with `equal'.
|
|
1679 If SEQ is not a list, or the first member of SEQ is ELT, deleting it
|
|
1680 is not a side effect; it is simply using a different sequence.
|
|
1681 Therefore, write `(setq foo (delete element foo))'
|
39977
|
1682 to be sure of changing the value of `foo'. */)
|
|
1683 (elt, seq)
|
30510
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1684 Lisp_Object elt, seq;
|
401
|
1685 {
|
30510
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1686 if (VECTORP (seq))
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1687 {
|
34961
|
1688 EMACS_INT i, n;
|
30510
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1689
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1690 for (i = n = 0; i < ASIZE (seq); ++i)
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1691 if (NILP (Fequal (AREF (seq, i), elt)))
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1692 ++n;
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1693
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1694 if (n != ASIZE (seq))
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1695 {
|
36431
|
1696 struct Lisp_Vector *p = allocate_vector (n);
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
1697
|
30510
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1698 for (i = n = 0; i < ASIZE (seq); ++i)
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1699 if (NILP (Fequal (AREF (seq, i), elt)))
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1700 p->contents[n++] = AREF (seq, i);
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1701
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1702 XSETVECTOR (seq, p);
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1703 }
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1704 }
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1705 else if (STRINGP (seq))
|
401
|
1706 {
|
30510
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1707 EMACS_INT i, ibyte, nchars, nbytes, cbytes;
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1708 int c;
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1709
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1710 for (i = nchars = nbytes = ibyte = 0;
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1711 i < SCHARS (seq);
|
30510
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1712 ++i, ibyte += cbytes)
|
401
|
1713 {
|
30510
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1714 if (STRING_MULTIBYTE (seq))
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1715 {
|
46425
|
1716 c = STRING_CHAR (SDATA (seq) + ibyte,
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1717 SBYTES (seq) - ibyte);
|
30510
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1718 cbytes = CHAR_BYTES (c);
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1719 }
|
401
|
1720 else
|
30510
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1721 {
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1722 c = SREF (seq, i);
|
30510
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1723 cbytes = 1;
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1724 }
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
1725
|
30510
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1726 if (!INTEGERP (elt) || c != XINT (elt))
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1727 {
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1728 ++nchars;
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1729 nbytes += cbytes;
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1730 }
|
401
|
1731 }
|
30510
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1732
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1733 if (nchars != SCHARS (seq))
|
30510
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1734 {
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1735 Lisp_Object tem;
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1736
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1737 tem = make_uninit_multibyte_string (nchars, nbytes);
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1738 if (!STRING_MULTIBYTE (seq))
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1739 STRING_SET_UNIBYTE (tem);
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
1740
|
30510
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1741 for (i = nchars = nbytes = ibyte = 0;
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1742 i < SCHARS (seq);
|
30510
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1743 ++i, ibyte += cbytes)
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1744 {
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1745 if (STRING_MULTIBYTE (seq))
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1746 {
|
46425
|
1747 c = STRING_CHAR (SDATA (seq) + ibyte,
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1748 SBYTES (seq) - ibyte);
|
30510
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1749 cbytes = CHAR_BYTES (c);
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1750 }
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1751 else
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1752 {
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
1753 c = SREF (seq, i);
|
30510
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1754 cbytes = 1;
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1755 }
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
1756
|
30510
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1757 if (!INTEGERP (elt) || c != XINT (elt))
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1758 {
|
46425
|
1759 unsigned char *from = SDATA (seq) + ibyte;
|
|
1760 unsigned char *to = SDATA (tem) + nbytes;
|
30510
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1761 EMACS_INT n;
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
1762
|
30510
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1763 ++nchars;
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1764 nbytes += cbytes;
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
1765
|
30510
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1766 for (n = cbytes; n--; )
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1767 *to++ = *from++;
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1768 }
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1769 }
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1770
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1771 seq = tem;
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1772 }
|
401
|
1773 }
|
30510
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1774 else
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1775 {
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1776 Lisp_Object tail, prev;
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1777
|
85330
|
1778 for (tail = seq, prev = Qnil; CONSP (tail); tail = XCDR (tail))
|
30510
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1779 {
|
71833
|
1780 CHECK_LIST_CONS (tail, seq);
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
1781
|
30510
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1782 if (!NILP (Fequal (elt, XCAR (tail))))
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1783 {
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1784 if (NILP (prev))
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1785 seq = XCDR (tail);
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1786 else
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1787 Fsetcdr (prev, XCDR (tail));
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1788 }
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1789 else
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1790 prev = tail;
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1791 QUIT;
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1792 }
|
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1793 }
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
1794
|
30510
4a2abe231277
(Fdelete): Make it work on vectors and strings in addition to lists.
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
1795 return seq;
|
401
|
1796 }
|
|
1797
|
211
|
1798 DEFUN ("nreverse", Fnreverse, Snreverse, 1, 1, 0,
|
39977
|
1799 doc: /* Reverse LIST by modifying cdr pointers.
|
53106
|
1800 Return the reversed list. */)
|
39977
|
1801 (list)
|
211
|
1802 Lisp_Object list;
|
|
1803 {
|
|
1804 register Lisp_Object prev, tail, next;
|
|
1805
|
485
|
1806 if (NILP (list)) return list;
|
211
|
1807 prev = Qnil;
|
|
1808 tail = list;
|
485
|
1809 while (!NILP (tail))
|
211
|
1810 {
|
|
1811 QUIT;
|
71833
|
1812 CHECK_LIST_CONS (tail, list);
|
26596
|
1813 next = XCDR (tail);
|
211
|
1814 Fsetcdr (tail, prev);
|
|
1815 prev = tail;
|
|
1816 tail = next;
|
|
1817 }
|
|
1818 return prev;
|
|
1819 }
|
|
1820
|
|
1821 DEFUN ("reverse", Freverse, Sreverse, 1, 1, 0,
|
53106
|
1822 doc: /* Reverse LIST, copying. Return the reversed list.
|
39977
|
1823 See also the function `nreverse', which is used more often. */)
|
|
1824 (list)
|
211
|
1825 Lisp_Object list;
|
|
1826 {
|
18421
|
1827 Lisp_Object new;
|
211
|
1828
|
25645
|
1829 for (new = Qnil; CONSP (list); list = XCDR (list))
|
49204
|
1830 {
|
|
1831 QUIT;
|
|
1832 new = Fcons (XCAR (list), new);
|
|
1833 }
|
71833
|
1834 CHECK_LIST_END (list, list);
|
18421
|
1835 return new;
|
211
|
1836 }
|
|
1837
|
|
1838 Lisp_Object merge ();
|
|
1839
|
|
1840 DEFUN ("sort", Fsort, Ssort, 2, 2, 0,
|
39977
|
1841 doc: /* Sort LIST, stably, comparing elements using PREDICATE.
|
39899
|
1842 Returns the sorted list. LIST is modified by side effects.
|
63602
|
1843 PREDICATE is called with two elements of LIST, and should return non-nil
|
65325
|
1844 if the first element should sort before the second. */)
|
39977
|
1845 (list, predicate)
|
14091
34911b128a47
(Frandom, Flength, Felt, Fsort, Fchar_table_subtype, Fchar_table_parent,
Erik Naggum <erik@naggum.no>
diff
changeset
|
1846 Lisp_Object list, predicate;
|
211
|
1847 {
|
|
1848 Lisp_Object front, back;
|
|
1849 register Lisp_Object len, tem;
|
|
1850 struct gcpro gcpro1, gcpro2;
|
|
1851 register int length;
|
|
1852
|
|
1853 front = list;
|
|
1854 len = Flength (list);
|
|
1855 length = XINT (len);
|
|
1856 if (length < 2)
|
|
1857 return list;
|
|
1858
|
|
1859 XSETINT (len, (length / 2) - 1);
|
|
1860 tem = Fnthcdr (len, list);
|
|
1861 back = Fcdr (tem);
|
|
1862 Fsetcdr (tem, Qnil);
|
|
1863
|
|
1864 GCPRO2 (front, back);
|
14091
34911b128a47
(Frandom, Flength, Felt, Fsort, Fchar_table_subtype, Fchar_table_parent,
Erik Naggum <erik@naggum.no>
diff
changeset
|
1865 front = Fsort (front, predicate);
|
34911b128a47
(Frandom, Flength, Felt, Fsort, Fchar_table_subtype, Fchar_table_parent,
Erik Naggum <erik@naggum.no>
diff
changeset
|
1866 back = Fsort (back, predicate);
|
211
|
1867 UNGCPRO;
|
14091
34911b128a47
(Frandom, Flength, Felt, Fsort, Fchar_table_subtype, Fchar_table_parent,
Erik Naggum <erik@naggum.no>
diff
changeset
|
1868 return merge (front, back, predicate);
|
211
|
1869 }
|
|
1870
|
|
1871 Lisp_Object
|
|
1872 merge (org_l1, org_l2, pred)
|
|
1873 Lisp_Object org_l1, org_l2;
|
|
1874 Lisp_Object pred;
|
|
1875 {
|
|
1876 Lisp_Object value;
|
|
1877 register Lisp_Object tail;
|
|
1878 Lisp_Object tem;
|
|
1879 register Lisp_Object l1, l2;
|
|
1880 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
|
|
1881
|
|
1882 l1 = org_l1;
|
|
1883 l2 = org_l2;
|
|
1884 tail = Qnil;
|
|
1885 value = Qnil;
|
|
1886
|
|
1887 /* It is sufficient to protect org_l1 and org_l2.
|
|
1888 When l1 and l2 are updated, we copy the new values
|
|
1889 back into the org_ vars. */
|
|
1890 GCPRO4 (org_l1, org_l2, pred, value);
|
|
1891
|
|
1892 while (1)
|
|
1893 {
|
485
|
1894 if (NILP (l1))
|
211
|
1895 {
|
|
1896 UNGCPRO;
|
485
|
1897 if (NILP (tail))
|
211
|
1898 return l2;
|
|
1899 Fsetcdr (tail, l2);
|
|
1900 return value;
|
|
1901 }
|
485
|
1902 if (NILP (l2))
|
211
|
1903 {
|
|
1904 UNGCPRO;
|
485
|
1905 if (NILP (tail))
|
211
|
1906 return l1;
|
|
1907 Fsetcdr (tail, l1);
|
|
1908 return value;
|
|
1909 }
|
|
1910 tem = call2 (pred, Fcar (l2), Fcar (l1));
|
485
|
1911 if (NILP (tem))
|
211
|
1912 {
|
|
1913 tem = l1;
|
|
1914 l1 = Fcdr (l1);
|
|
1915 org_l1 = l1;
|
|
1916 }
|
|
1917 else
|
|
1918 {
|
|
1919 tem = l2;
|
|
1920 l2 = Fcdr (l2);
|
|
1921 org_l2 = l2;
|
|
1922 }
|
485
|
1923 if (NILP (tail))
|
211
|
1924 value = tem;
|
|
1925 else
|
|
1926 Fsetcdr (tail, tem);
|
|
1927 tail = tem;
|
|
1928 }
|
|
1929 }
|
37279
|
1930
|
211
|
1931
|
61723
|
1932 #if 0 /* Unsafe version. */
|
11130
|
1933 DEFUN ("plist-get", Fplist_get, Splist_get, 2, 2, 0,
|
39977
|
1934 doc: /* Extract a value from a property list.
|
39899
|
1935 PLIST is a property list, which is a list of the form
|
|
1936 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
|
|
1937 corresponding to the given PROP, or nil if PROP is not
|
39977
|
1938 one of the properties on the list. */)
|
|
1939 (plist, prop)
|
14051
|
1940 Lisp_Object plist;
|
37279
|
1941 Lisp_Object prop;
|
211
|
1942 {
|
37279
|
1943 Lisp_Object tail;
|
49246
|
1944
|
37279
|
1945 for (tail = plist;
|
|
1946 CONSP (tail) && CONSP (XCDR (tail));
|
|
1947 tail = XCDR (XCDR (tail)))
|
211
|
1948 {
|
37279
|
1949 if (EQ (prop, XCAR (tail)))
|
|
1950 return XCAR (XCDR (tail));
|
37317
|
1951
|
|
1952 /* This function can be called asynchronously
|
|
1953 (setup_coding_system). Don't QUIT in that case. */
|
|
1954 if (!interrupt_input_blocked)
|
|
1955 QUIT;
|
211
|
1956 }
|
37279
|
1957
|
71833
|
1958 CHECK_LIST_END (tail, prop);
|
49246
|
1959
|
211
|
1960 return Qnil;
|
|
1961 }
|
61723
|
1962 #endif
|
|
1963
|
|
1964 /* This does not check for quits. That is safe since it must terminate. */
|
|
1965
|
|
1966 DEFUN ("plist-get", Fplist_get, Splist_get, 2, 2, 0,
|
58239
|
1967 doc: /* Extract a value from a property list.
|
|
1968 PLIST is a property list, which is a list of the form
|
|
1969 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
|
61723
|
1970 corresponding to the given PROP, or nil if PROP is not one of the
|
|
1971 properties on the list. This function never signals an error. */)
|
58239
|
1972 (plist, prop)
|
|
1973 Lisp_Object plist;
|
|
1974 Lisp_Object prop;
|
|
1975 {
|
|
1976 Lisp_Object tail, halftail;
|
|
1977
|
|
1978 /* halftail is used to detect circular lists. */
|
|
1979 tail = halftail = plist;
|
|
1980 while (CONSP (tail) && CONSP (XCDR (tail)))
|
|
1981 {
|
|
1982 if (EQ (prop, XCAR (tail)))
|
|
1983 return XCAR (XCDR (tail));
|
|
1984
|
|
1985 tail = XCDR (XCDR (tail));
|
|
1986 halftail = XCDR (halftail);
|
|
1987 if (EQ (tail, halftail))
|
|
1988 break;
|
|
1989 }
|
|
1990
|
|
1991 return Qnil;
|
|
1992 }
|
|
1993
|
11130
|
1994 DEFUN ("get", Fget, Sget, 2, 2, 0,
|
39977
|
1995 doc: /* Return the value of SYMBOL's PROPNAME property.
|
|
1996 This is the last value stored with `(put SYMBOL PROPNAME VALUE)'. */)
|
|
1997 (symbol, propname)
|
11138
|
1998 Lisp_Object symbol, propname;
|
11130
|
1999 {
|
40656
|
2000 CHECK_SYMBOL (symbol);
|
11138
|
2001 return Fplist_get (XSYMBOL (symbol)->plist, propname);
|
11130
|
2002 }
|
|
2003
|
|
2004 DEFUN ("plist-put", Fplist_put, Splist_put, 3, 3, 0,
|
39977
|
2005 doc: /* Change value in PLIST of PROP to VAL.
|
39899
|
2006 PLIST is a property list, which is a list of the form
|
|
2007 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
|
|
2008 If PROP is already a property on the list, its value is set to VAL,
|
|
2009 otherwise the new PROP VAL pair is added. The new plist is returned;
|
|
2010 use `(setq x (plist-put x prop val))' to be sure to use the new value.
|
39977
|
2011 The PLIST is modified by side effects. */)
|
|
2012 (plist, prop, val)
|
20004
|
2013 Lisp_Object plist;
|
|
2014 register Lisp_Object prop;
|
|
2015 Lisp_Object val;
|
211
|
2016 {
|
|
2017 register Lisp_Object tail, prev;
|
|
2018 Lisp_Object newcell;
|
|
2019 prev = Qnil;
|
25645
|
2020 for (tail = plist; CONSP (tail) && CONSP (XCDR (tail));
|
|
2021 tail = XCDR (XCDR (tail)))
|
211
|
2022 {
|
25645
|
2023 if (EQ (prop, XCAR (tail)))
|
11130
|
2024 {
|
25645
|
2025 Fsetcar (XCDR (tail), val);
|
11130
|
2026 return plist;
|
|
2027 }
|
49246
|
2028
|
211
|
2029 prev = tail;
|
37279
|
2030 QUIT;
|
211
|
2031 }
|
78824
|
2032 newcell = Fcons (prop, Fcons (val, NILP (prev) ? plist : XCDR (XCDR (prev))));
|
485
|
2033 if (NILP (prev))
|
11130
|
2034 return newcell;
|
211
|
2035 else
|
25645
|
2036 Fsetcdr (XCDR (prev), newcell);
|
11130
|
2037 return plist;
|
|
2038 }
|
|
2039
|
|
2040 DEFUN ("put", Fput, Sput, 3, 3, 0,
|
39977
|
2041 doc: /* Store SYMBOL's PROPNAME property with value VALUE.
|
|
2042 It can be retrieved with `(get SYMBOL PROPNAME)'. */)
|
|
2043 (symbol, propname, value)
|
11138
|
2044 Lisp_Object symbol, propname, value;
|
11130
|
2045 {
|
40656
|
2046 CHECK_SYMBOL (symbol);
|
11138
|
2047 XSYMBOL (symbol)->plist
|
|
2048 = Fplist_put (XSYMBOL (symbol)->plist, propname, value);
|
|
2049 return value;
|
211
|
2050 }
|
44159
|
2051
|
|
2052 DEFUN ("lax-plist-get", Flax_plist_get, Slax_plist_get, 2, 2, 0,
|
|
2053 doc: /* Extract a value from a property list, comparing with `equal'.
|
|
2054 PLIST is a property list, which is a list of the form
|
|
2055 \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
|
|
2056 corresponding to the given PROP, or nil if PROP is not
|
|
2057 one of the properties on the list. */)
|
|
2058 (plist, prop)
|
|
2059 Lisp_Object plist;
|
|
2060 Lisp_Object prop;
|
|
2061 {
|
|
2062 Lisp_Object tail;
|
49246
|
2063
|
44159
|
2064 for (tail = plist;
|
|
2065 CONSP (tail) && CONSP (XCDR (tail));
|
|
2066 tail = XCDR (XCDR (tail)))
|
|
2067 {
|
|
2068 if (! NILP (Fequal (prop, XCAR (tail))))
|
|
2069 return XCAR (XCDR (tail));
|
|
2070
|
|
2071 QUIT;
|
|
2072 }
|
|
2073
|
71833
|
2074 CHECK_LIST_END (tail, prop);
|
49246
|
2075
|
44159
|
2076 return Qnil;
|
|
2077 }
|
|
2078
|
|
2079 DEFUN ("lax-plist-put", Flax_plist_put, Slax_plist_put, 3, 3, 0,
|
|
2080 doc: /* Change value in PLIST of PROP to VAL, comparing with `equal'.
|
|
2081 PLIST is a property list, which is a list of the form
|
44219
|
2082 \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP and VAL are any objects.
|
44159
|
2083 If PROP is already a property on the list, its value is set to VAL,
|
|
2084 otherwise the new PROP VAL pair is added. The new plist is returned;
|
|
2085 use `(setq x (lax-plist-put x prop val))' to be sure to use the new value.
|
|
2086 The PLIST is modified by side effects. */)
|
|
2087 (plist, prop, val)
|
|
2088 Lisp_Object plist;
|
|
2089 register Lisp_Object prop;
|
|
2090 Lisp_Object val;
|
|
2091 {
|
|
2092 register Lisp_Object tail, prev;
|
|
2093 Lisp_Object newcell;
|
|
2094 prev = Qnil;
|
|
2095 for (tail = plist; CONSP (tail) && CONSP (XCDR (tail));
|
|
2096 tail = XCDR (XCDR (tail)))
|
|
2097 {
|
|
2098 if (! NILP (Fequal (prop, XCAR (tail))))
|
|
2099 {
|
|
2100 Fsetcar (XCDR (tail), val);
|
|
2101 return plist;
|
|
2102 }
|
49246
|
2103
|
44159
|
2104 prev = tail;
|
|
2105 QUIT;
|
|
2106 }
|
|
2107 newcell = Fcons (prop, Fcons (val, Qnil));
|
|
2108 if (NILP (prev))
|
|
2109 return newcell;
|
|
2110 else
|
|
2111 Fsetcdr (XCDR (prev), newcell);
|
|
2112 return plist;
|
|
2113 }
|
|
2114
|
54987
|
2115 DEFUN ("eql", Feql, Seql, 2, 2, 0,
|
|
2116 doc: /* Return t if the two args are the same Lisp object.
|
|
2117 Floating-point numbers of equal value are `eql', but they may not be `eq'. */)
|
54994
|
2118 (obj1, obj2)
|
54987
|
2119 Lisp_Object obj1, obj2;
|
|
2120 {
|
|
2121 if (FLOATP (obj1))
|
|
2122 return internal_equal (obj1, obj2, 0, 0) ? Qt : Qnil;
|
|
2123 else
|
|
2124 return EQ (obj1, obj2) ? Qt : Qnil;
|
|
2125 }
|
|
2126
|
211
|
2127 DEFUN ("equal", Fequal, Sequal, 2, 2, 0,
|
39977
|
2128 doc: /* Return t if two Lisp objects have similar structure and contents.
|
39899
|
2129 They must have the same data type.
|
|
2130 Conses are compared by comparing the cars and the cdrs.
|
|
2131 Vectors and strings are compared element by element.
|
|
2132 Numbers are compared by value, but integers cannot equal floats.
|
|
2133 (Use `=' if you want integers and floats to be able to be equal.)
|
39977
|
2134 Symbols must match exactly. */)
|
|
2135 (o1, o2)
|
211
|
2136 register Lisp_Object o1, o2;
|
|
2137 {
|
54373
|
2138 return internal_equal (o1, o2, 0, 0) ? Qt : Qnil;
|
399
|
2139 }
|
|
2140
|
54373
|
2141 DEFUN ("equal-including-properties", Fequal_including_properties, Sequal_including_properties, 2, 2, 0,
|
|
2142 doc: /* Return t if two Lisp objects have similar structure and contents.
|
|
2143 This is like `equal' except that it compares the text properties
|
|
2144 of strings. (`equal' ignores text properties.) */)
|
|
2145 (o1, o2)
|
|
2146 register Lisp_Object o1, o2;
|
|
2147 {
|
|
2148 return internal_equal (o1, o2, 0, 1) ? Qt : Qnil;
|
|
2149 }
|
|
2150
|
|
2151 /* DEPTH is current depth of recursion. Signal an error if it
|
|
2152 gets too deep.
|
|
2153 PROPS, if non-nil, means compare string text properties too. */
|
|
2154
|
9927
|
2155 static int
|
54373
|
2156 internal_equal (o1, o2, depth, props)
|
399
|
2157 register Lisp_Object o1, o2;
|
54373
|
2158 int depth, props;
|
399
|
2159 {
|
|
2160 if (depth > 200)
|
|
2161 error ("Stack overflow in equal");
|
10405
|
2162
|
9927
|
2163 tail_recurse:
|
211
|
2164 QUIT;
|
10405
|
2165 if (EQ (o1, o2))
|
|
2166 return 1;
|
|
2167 if (XTYPE (o1) != XTYPE (o2))
|
|
2168 return 0;
|
|
2169
|
|
2170 switch (XTYPE (o1))
|
211
|
2171 {
|
10405
|
2172 case Lisp_Float:
|
53393
|
2173 {
|
|
2174 double d1, d2;
|
|
2175
|
|
2176 d1 = extract_float (o1);
|
|
2177 d2 = extract_float (o2);
|
|
2178 /* If d is a NaN, then d != d. Two NaNs should be `equal' even
|
|
2179 though they are not =. */
|
|
2180 return d1 == d2 || (d1 != d1 && d2 != d2);
|
|
2181 }
|
10405
|
2182
|
|
2183 case Lisp_Cons:
|
54373
|
2184 if (!internal_equal (XCAR (o1), XCAR (o2), depth + 1, props))
|
10411
|
2185 return 0;
|
25645
|
2186 o1 = XCDR (o1);
|
|
2187 o2 = XCDR (o2);
|
10411
|
2188 goto tail_recurse;
|
10405
|
2189
|
|
2190 case Lisp_Misc:
|
11240
|
2191 if (XMISCTYPE (o1) != XMISCTYPE (o2))
|
9927
|
2192 return 0;
|
10405
|
2193 if (OVERLAYP (o1))
|
211
|
2194 {
|
25149
|
2195 if (!internal_equal (OVERLAY_START (o1), OVERLAY_START (o2),
|
54373
|
2196 depth + 1, props)
|
25149
|
2197 || !internal_equal (OVERLAY_END (o1), OVERLAY_END (o2),
|
65713
|
2198 depth + 1, props))
|
9927
|
2199 return 0;
|
10405
|
2200 o1 = XOVERLAY (o1)->plist;
|
|
2201 o2 = XOVERLAY (o2)->plist;
|
|
2202 goto tail_recurse;
|
|
2203 }
|
|
2204 if (MARKERP (o1))
|
|
2205 {
|
|
2206 return (XMARKER (o1)->buffer == XMARKER (o2)->buffer
|
|
2207 && (XMARKER (o1)->buffer == 0
|
20567
|
2208 || XMARKER (o1)->bytepos == XMARKER (o2)->bytepos));
|
211
|
2209 }
|
10405
|
2210 break;
|
|
2211
|
|
2212 case Lisp_Vectorlike:
|
10411
|
2213 {
|
53159
|
2214 register int i;
|
74163
|
2215 EMACS_INT size = ASIZE (o1);
|
10411
|
2216 /* Pseudovectors have the type encoded in the size field, so this test
|
|
2217 actually checks that the objects have the same type as well as the
|
|
2218 same size. */
|
74163
|
2219 if (ASIZE (o2) != size)
|
10411
|
2220 return 0;
|
13140
|
2221 /* Boolvectors are compared much like strings. */
|
|
2222 if (BOOL_VECTOR_P (o1))
|
|
2223 {
|
|
2224 int size_in_chars
|
55161
beac72c0215f
(Fcopy_sequence, concat, internal_equal, Ffillarray, mapcar1): Use
Andreas Schwab <schwab@suse.de>
diff
changeset
|
2225 = ((XBOOL_VECTOR (o1)->size + BOOL_VECTOR_BITS_PER_CHAR - 1)
|
beac72c0215f
(Fcopy_sequence, concat, internal_equal, Ffillarray, mapcar1): Use
Andreas Schwab <schwab@suse.de>
diff
changeset
|
2226 / BOOL_VECTOR_BITS_PER_CHAR);
|
13140
|
2227
|
|
2228 if (XBOOL_VECTOR (o1)->size != XBOOL_VECTOR (o2)->size)
|
|
2229 return 0;
|
|
2230 if (bcmp (XBOOL_VECTOR (o1)->data, XBOOL_VECTOR (o2)->data,
|
|
2231 size_in_chars))
|
|
2232 return 0;
|
|
2233 return 1;
|
|
2234 }
|
20776
|
2235 if (WINDOW_CONFIGURATIONP (o1))
|
21021
|
2236 return compare_window_configurations (o1, o2, 0);
|
13140
|
2237
|
94929
|
2238 /* Aside from them, only true vectors, char-tables, compiled
|
|
2239 functions, and fonts (font-spec, font-entity, font-ojbect)
|
|
2240 are sensible to compare, so eliminate the others now. */
|
10411
|
2241 if (size & PSEUDOVECTOR_FLAG)
|
|
2242 {
|
89483
|
2243 if (!(size & (PVEC_COMPILED
|
94929
|
2244 | PVEC_CHAR_TABLE | PVEC_SUB_CHAR_TABLE | PVEC_FONT)))
|
10411
|
2245 return 0;
|
|
2246 size &= PSEUDOVECTOR_SIZE_MASK;
|
|
2247 }
|
|
2248 for (i = 0; i < size; i++)
|
|
2249 {
|
|
2250 Lisp_Object v1, v2;
|
74163
|
2251 v1 = AREF (o1, i);
|
|
2252 v2 = AREF (o2, i);
|
54373
|
2253 if (!internal_equal (v1, v2, depth + 1, props))
|
10411
|
2254 return 0;
|
|
2255 }
|
|
2256 return 1;
|
|
2257 }
|
10405
|
2258 break;
|
|
2259
|
|
2260 case Lisp_String:
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
2261 if (SCHARS (o1) != SCHARS (o2))
|
10411
|
2262 return 0;
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
2263 if (SBYTES (o1) != SBYTES (o2))
|
20607
|
2264 return 0;
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
2265 if (bcmp (SDATA (o1), SDATA (o2),
|
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
2266 SBYTES (o1)))
|
10411
|
2267 return 0;
|
54373
|
2268 if (props && !compare_string_intervals (o1, o2))
|
|
2269 return 0;
|
10411
|
2270 return 1;
|
31533
|
2271
|
|
2272 case Lisp_Int:
|
|
2273 case Lisp_Symbol:
|
|
2274 case Lisp_Type_Limit:
|
|
2275 break;
|
211
|
2276 }
|
49246
|
2277
|
9927
|
2278 return 0;
|
211
|
2279 }
|
|
2280
|
18613
|
2281 extern Lisp_Object Fmake_char_internal ();
|
|
2282
|
211
|
2283 DEFUN ("fillarray", Ffillarray, Sfillarray, 2, 2, 0,
|
39977
|
2284 doc: /* Store each element of ARRAY with ITEM.
|
|
2285 ARRAY is a vector, string, char-table, or bool-vector. */)
|
|
2286 (array, item)
|
211
|
2287 Lisp_Object array, item;
|
|
2288 {
|
|
2289 register int size, index, charval;
|
9128
04a702d7f662
(Frandom, Flength, Fstring_equal, Fstring_lessp, Fcopy_sequence, concat, Felt,
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
2290 if (VECTORP (array))
|
211
|
2291 {
|
|
2292 register Lisp_Object *p = XVECTOR (array)->contents;
|
74163
|
2293 size = ASIZE (array);
|
211
|
2294 for (index = 0; index < size; index++)
|
|
2295 p[index] = item;
|
|
2296 }
|
13140
|
2297 else if (CHAR_TABLE_P (array))
|
|
2298 {
|
88375
|
2299 int i;
|
|
2300
|
|
2301 for (i = 0; i < (1 << CHARTAB_SIZE_BITS_0); i++)
|
|
2302 XCHAR_TABLE (array)->contents[i] = item;
|
|
2303 XCHAR_TABLE (array)->defalt = item;
|
13140
|
2304 }
|
9128
04a702d7f662
(Frandom, Flength, Fstring_equal, Fstring_lessp, Fcopy_sequence, concat, Felt,
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
2305 else if (STRINGP (array))
|
211
|
2306 {
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
2307 register unsigned char *p = SDATA (array);
|
40656
|
2308 CHECK_NUMBER (item);
|
211
|
2309 charval = XINT (item);
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
2310 size = SCHARS (array);
|
23424
|
2311 if (STRING_MULTIBYTE (array))
|
|
2312 {
|
26856
|
2313 unsigned char str[MAX_MULTIBYTE_LENGTH];
|
|
2314 int len = CHAR_STRING (charval, str);
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
2315 int size_byte = SBYTES (array);
|
23424
|
2316 unsigned char *p1 = p, *endp = p + size_byte;
|
23453
|
2317 int i;
|
|
2318
|
|
2319 if (size != size_byte)
|
|
2320 while (p1 < endp)
|
|
2321 {
|
|
2322 int this_len = MULTIBYTE_FORM_LENGTH (p1, endp - p1);
|
|
2323 if (len != this_len)
|
|
2324 error ("Attempt to change byte length of a string");
|
|
2325 p1 += this_len;
|
|
2326 }
|
23424
|
2327 for (i = 0; i < size_byte; i++)
|
|
2328 *p++ = str[i % len];
|
|
2329 }
|
|
2330 else
|
|
2331 for (index = 0; index < size; index++)
|
|
2332 p[index] = charval;
|
211
|
2333 }
|
13140
|
2334 else if (BOOL_VECTOR_P (array))
|
|
2335 {
|
|
2336 register unsigned char *p = XBOOL_VECTOR (array)->data;
|
|
2337 int size_in_chars
|
55161
beac72c0215f
(Fcopy_sequence, concat, internal_equal, Ffillarray, mapcar1): Use
Andreas Schwab <schwab@suse.de>
diff
changeset
|
2338 = ((XBOOL_VECTOR (array)->size + BOOL_VECTOR_BITS_PER_CHAR - 1)
|
beac72c0215f
(Fcopy_sequence, concat, internal_equal, Ffillarray, mapcar1): Use
Andreas Schwab <schwab@suse.de>
diff
changeset
|
2339 / BOOL_VECTOR_BITS_PER_CHAR);
|
13140
|
2340
|
|
2341 charval = (! NILP (item) ? -1 : 0);
|
53159
|
2342 for (index = 0; index < size_in_chars - 1; index++)
|
13140
|
2343 p[index] = charval;
|
53159
|
2344 if (index < size_in_chars)
|
|
2345 {
|
|
2346 /* Mask out bits beyond the vector size. */
|
55161
beac72c0215f
(Fcopy_sequence, concat, internal_equal, Ffillarray, mapcar1): Use
Andreas Schwab <schwab@suse.de>
diff
changeset
|
2347 if (XBOOL_VECTOR (array)->size % BOOL_VECTOR_BITS_PER_CHAR)
|
beac72c0215f
(Fcopy_sequence, concat, internal_equal, Ffillarray, mapcar1): Use
Andreas Schwab <schwab@suse.de>
diff
changeset
|
2348 charval &= (1 << (XBOOL_VECTOR (array)->size % BOOL_VECTOR_BITS_PER_CHAR)) - 1;
|
53159
|
2349 p[index] = charval;
|
|
2350 }
|
13140
|
2351 }
|
211
|
2352 else
|
71833
|
2353 wrong_type_argument (Qarrayp, array);
|
211
|
2354 return array;
|
|
2355 }
|
52075
|
2356
|
|
2357 DEFUN ("clear-string", Fclear_string, Sclear_string,
|
|
2358 1, 1, 0,
|
|
2359 doc: /* Clear the contents of STRING.
|
|
2360 This makes STRING unibyte and may change its length. */)
|
|
2361 (string)
|
|
2362 Lisp_Object string;
|
|
2363 {
|
56364
|
2364 int len;
|
56358
|
2365 CHECK_STRING (string);
|
56364
|
2366 len = SBYTES (string);
|
52075
|
2367 bzero (SDATA (string), len);
|
|
2368 STRING_SET_CHARS (string, len);
|
|
2369 STRING_SET_UNIBYTE (string);
|
|
2370 return Qnil;
|
|
2371 }
|
20607
|
2372
|
211
|
2373 /* ARGSUSED */
|
|
2374 Lisp_Object
|
|
2375 nconc2 (s1, s2)
|
|
2376 Lisp_Object s1, s2;
|
|
2377 {
|
|
2378 #ifdef NO_ARG_ARRAY
|
|
2379 Lisp_Object args[2];
|
|
2380 args[0] = s1;
|
|
2381 args[1] = s2;
|
|
2382 return Fnconc (2, args);
|
|
2383 #else
|
|
2384 return Fnconc (2, &s1);
|
|
2385 #endif /* NO_ARG_ARRAY */
|
|
2386 }
|
|
2387
|
|
2388 DEFUN ("nconc", Fnconc, Snconc, 0, MANY, 0,
|
39977
|
2389 doc: /* Concatenate any number of lists by altering them.
|
40132
75fe73bea452
(Fappend, Fconcat, Fvconcat, Fnconc, Fwidget_apply, Fmake_hash_table):
Miles Bader <miles@gnu.org>
diff
changeset
|
2390 Only the last argument is not altered, and need not be a list.
|
75fe73bea452
(Fappend, Fconcat, Fvconcat, Fnconc, Fwidget_apply, Fmake_hash_table):
Miles Bader <miles@gnu.org>
diff
changeset
|
2391 usage: (nconc &rest LISTS) */)
|
39977
|
2392 (nargs, args)
|
211
|
2393 int nargs;
|
|
2394 Lisp_Object *args;
|
|
2395 {
|
|
2396 register int argnum;
|
|
2397 register Lisp_Object tail, tem, val;
|
|
2398
|
31533
|
2399 val = tail = Qnil;
|
211
|
2400
|
|
2401 for (argnum = 0; argnum < nargs; argnum++)
|
|
2402 {
|
|
2403 tem = args[argnum];
|
485
|
2404 if (NILP (tem)) continue;
|
211
|
2405
|
485
|
2406 if (NILP (val))
|
211
|
2407 val = tem;
|
|
2408
|
|
2409 if (argnum + 1 == nargs) break;
|
|
2410
|
71833
|
2411 CHECK_LIST_CONS (tem, tem);
|
211
|
2412
|
|
2413 while (CONSP (tem))
|
|
2414 {
|
|
2415 tail = tem;
|
46221
|
2416 tem = XCDR (tail);
|
211
|
2417 QUIT;
|
|
2418 }
|
|
2419
|
|
2420 tem = args[argnum + 1];
|
|
2421 Fsetcdr (tail, tem);
|
485
|
2422 if (NILP (tem))
|
211
|
2423 args[argnum + 1] = tail;
|
|
2424 }
|
|
2425
|
|
2426 return val;
|
|
2427 }
|
|
2428
|
|
2429 /* This is the guts of all mapping functions.
|
20607
|
2430 Apply FN to each element of SEQ, one by one,
|
|
2431 storing the results into elements of VALS, a C vector of Lisp_Objects.
|
|
2432 LENI is the length of VALS, which should also be the length of SEQ. */
|
211
|
2433
|
|
2434 static void
|
|
2435 mapcar1 (leni, vals, fn, seq)
|
|
2436 int leni;
|
|
2437 Lisp_Object *vals;
|
|
2438 Lisp_Object fn, seq;
|
|
2439 {
|
|
2440 register Lisp_Object tail;
|
|
2441 Lisp_Object dummy;
|
|
2442 register int i;
|
|
2443 struct gcpro gcpro1, gcpro2, gcpro3;
|
|
2444
|
28555
|
2445 if (vals)
|
|
2446 {
|
|
2447 /* Don't let vals contain any garbage when GC happens. */
|
|
2448 for (i = 0; i < leni; i++)
|
|
2449 vals[i] = Qnil;
|
|
2450
|
|
2451 GCPRO3 (dummy, fn, seq);
|
|
2452 gcpro1.var = vals;
|
|
2453 gcpro1.nvars = leni;
|
|
2454 }
|
|
2455 else
|
|
2456 GCPRO2 (fn, seq);
|
211
|
2457 /* We need not explicitly protect `tail' because it is used only on lists, and
|
74163
|
2458 1) lists are not relocated and 2) the list is marked via `seq' so will not
|
|
2459 be freed */
|
211
|
2460
|
9128
04a702d7f662
(Frandom, Flength, Fstring_equal, Fstring_lessp, Fcopy_sequence, concat, Felt,
Karl Heuer <kwzh@gnu.org>
diff
changeset
|
2461 if (VECTORP (seq))
|
211
|
2462 {
|
|
2463 for (i = 0; i < leni; i++)
|
|
2464 {
|
74163
|
2465 dummy = call1 (fn, AREF (seq, i));
|
28555
|
2466 if (vals)
|
|
2467 vals[i] = dummy;
|
211
|
2468 }
|
|
2469 }
|
20992
|
2470 else if (BOOL_VECTOR_P (seq))
|
|
2471 {
|
|
2472 for (i = 0; i < leni; i++)
|
|
2473 {
|
|
2474 int byte;
|
55161
beac72c0215f
(Fcopy_sequence, concat, internal_equal, Ffillarray, mapcar1): Use
Andreas Schwab <schwab@suse.de>
diff
changeset
|
2475 byte = XBOOL_VECTOR (seq)->data[i / BOOL_VECTOR_BITS_PER_CHAR];
|
74163
|
2476 dummy = (byte & (1 << (i % BOOL_VECTOR_BITS_PER_CHAR))) ? Qt : Qnil;
|
28555
|
2477 dummy = call1 (fn, dummy);
|
|
2478 if (vals)
|
|
2479 vals[i] = dummy;
|
20992
|
2480 }
|
|
2481 }
|
20607
|
2482 else if (STRINGP (seq))
|
|
2483 {
|
|
2484 int i_byte;
|
|
2485
|
|
2486 for (i = 0, i_byte = 0; i < leni;)
|
|
2487 {
|
|
2488 int c;
|
20712
|
2489 int i_before = i;
|
|
2490
|
|
2491 FETCH_STRING_CHAR_ADVANCE (c, seq, i, i_byte);
|
20607
|
2492 XSETFASTINT (dummy, c);
|
28555
|
2493 dummy = call1 (fn, dummy);
|
|
2494 if (vals)
|
|
2495 vals[i_before] = dummy;
|
20607
|
2496 }
|
|
2497 }
|
211
|
2498 else /* Must be a list, since Flength did not get an error */
|
|
2499 {
|
|
2500 tail = seq;
|
62950
|
2501 for (i = 0; i < leni && CONSP (tail); i++)
|
211
|
2502 {
|
62950
|
2503 dummy = call1 (fn, XCAR (tail));
|
28555
|
2504 if (vals)
|
|
2505 vals[i] = dummy;
|
25645
|
2506 tail = XCDR (tail);
|
211
|
2507 }
|
|
2508 }
|
|
2509
|
|
2510 UNGCPRO;
|
|
2511 }
|
|
2512
|
|
2513 DEFUN ("mapconcat", Fmapconcat, Smapconcat, 3, 3, 0,
|
39977
|
2514 doc: /* Apply FUNCTION to each element of SEQUENCE, and concat the results as strings.
|
39956
|
2515 In between each pair of results, stick in SEPARATOR. Thus, " " as
|
39899
|
2516 SEPARATOR results in spaces between the values returned by FUNCTION.
|
39977
|
2517 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
|
|
2518 (function, sequence, separator)
|
14091
34911b128a47
(Frandom, Flength, Felt, Fsort, Fchar_table_subtype, Fchar_table_parent,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2519 Lisp_Object function, sequence, separator;
|
211
|
2520 {
|
|
2521 Lisp_Object len;
|
|
2522 register int leni;
|
|
2523 int nargs;
|
|
2524 register Lisp_Object *args;
|
|
2525 register int i;
|
|
2526 struct gcpro gcpro1;
|
56195
|
2527 Lisp_Object ret;
|
|
2528 USE_SAFE_ALLOCA;
|
211
|
2529
|
14091
34911b128a47
(Frandom, Flength, Felt, Fsort, Fchar_table_subtype, Fchar_table_parent,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2530 len = Flength (sequence);
|
89624
|
2531 if (CHAR_TABLE_P (sequence))
|
|
2532 wrong_type_argument (Qlistp, sequence);
|
211
|
2533 leni = XINT (len);
|
|
2534 nargs = leni + leni - 1;
|
81283
|
2535 if (nargs < 0) return empty_unibyte_string;
|
211
|
2536
|
56203
|
2537 SAFE_ALLOCA_LISP (args, nargs);
|
211
|
2538
|
14091
34911b128a47
(Frandom, Flength, Felt, Fsort, Fchar_table_subtype, Fchar_table_parent,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2539 GCPRO1 (separator);
|
34911b128a47
(Frandom, Flength, Felt, Fsort, Fchar_table_subtype, Fchar_table_parent,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2540 mapcar1 (leni, args, function, sequence);
|
211
|
2541 UNGCPRO;
|
|
2542
|
62950
|
2543 for (i = leni - 1; i > 0; i--)
|
211
|
2544 args[i + i] = args[i];
|
20004
|
2545
|
211
|
2546 for (i = 1; i < nargs; i += 2)
|
14091
34911b128a47
(Frandom, Flength, Felt, Fsort, Fchar_table_subtype, Fchar_table_parent,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2547 args[i] = separator;
|
211
|
2548
|
56195
|
2549 ret = Fconcat (nargs, args);
|
57726
|
2550 SAFE_FREE ();
|
56195
|
2551
|
|
2552 return ret;
|
211
|
2553 }
|
|
2554
|
|
2555 DEFUN ("mapcar", Fmapcar, Smapcar, 2, 2, 0,
|
39977
|
2556 doc: /* Apply FUNCTION to each element of SEQUENCE, and make a list of the results.
|
39899
|
2557 The result is a list just as long as SEQUENCE.
|
39977
|
2558 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
|
|
2559 (function, sequence)
|
14091
34911b128a47
(Frandom, Flength, Felt, Fsort, Fchar_table_subtype, Fchar_table_parent,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2560 Lisp_Object function, sequence;
|
211
|
2561 {
|
|
2562 register Lisp_Object len;
|
|
2563 register int leni;
|
|
2564 register Lisp_Object *args;
|
56195
|
2565 Lisp_Object ret;
|
|
2566 USE_SAFE_ALLOCA;
|
211
|
2567
|
14091
34911b128a47
(Frandom, Flength, Felt, Fsort, Fchar_table_subtype, Fchar_table_parent,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2568 len = Flength (sequence);
|
89624
|
2569 if (CHAR_TABLE_P (sequence))
|
|
2570 wrong_type_argument (Qlistp, sequence);
|
211
|
2571 leni = XFASTINT (len);
|
56195
|
2572
|
56203
|
2573 SAFE_ALLOCA_LISP (args, leni);
|
211
|
2574
|
14091
34911b128a47
(Frandom, Flength, Felt, Fsort, Fchar_table_subtype, Fchar_table_parent,
Erik Naggum <erik@naggum.no>
diff
changeset
|
2575 mapcar1 (leni, args, function, sequence);
|
211
|
2576
|
56195
|
2577 ret = Flist (leni, args);
|
57726
|
2578 SAFE_FREE ();
|
56195
|
2579
|
|
2580 return ret;
|
211
|
2581 }
|
28555
|
2582
|
|
2583 DEFUN ("mapc", Fmapc, Smapc, 2, 2, 0,
|
39977
|
2584 doc: /* Apply FUNCTION to each element of SEQUENCE for side effects only.
|
39899
|
2585 Unlike `mapcar', don't accumulate the results. Return SEQUENCE.
|
39977
|
2586 SEQUENCE may be a list, a vector, a bool-vector, or a string. */)
|
|
2587 (function, sequence)
|
28555
|
2588 Lisp_Object function, sequence;
|
|
2589 {
|
|
2590 register int leni;
|
|
2591
|
|
2592 leni = XFASTINT (Flength (sequence));
|
89624
|
2593 if (CHAR_TABLE_P (sequence))
|
|
2594 wrong_type_argument (Qlistp, sequence);
|
28555
|
2595 mapcar1 (leni, 0, function, sequence);
|
|
2596
|
|
2597 return sequence;
|
|
2598 }
|
211
|
2599
|
|
2600 /* Anything that calls this function must protect from GC! */
|
|
2601
|
|
2602 DEFUN ("y-or-n-p", Fy_or_n_p, Sy_or_n_p, 1, 1, 0,
|
39977
|
2603 doc: /* Ask user a "y or n" question. Return t if answer is "y".
|
39899
|
2604 Takes one argument, which is the string to display to ask the question.
|
|
2605 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
|
|
2606 No confirmation of the answer is requested; a single character is enough.
|
|
2607 Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses
|
|
2608 the bindings in `query-replace-map'; see the documentation of that variable
|
|
2609 for more information. In this case, the useful bindings are `act', `skip',
|
|
2610 `recenter', and `quit'.\)
|
|
2611
|
|
2612 Under a windowing system a dialog box will be used if `last-nonmenu-event'
|
39977
|
2613 is nil and `use-dialog-box' is non-nil. */)
|
|
2614 (prompt)
|
211
|
2615 Lisp_Object prompt;
|
|
2616 {
|
25071
|
2617 register Lisp_Object obj, key, def, map;
|
2091
|
2618 register int answer;
|
211
|
2619 Lisp_Object xprompt;
|
|
2620 Lisp_Object args[2];
|
|
2621 struct gcpro gcpro1, gcpro2;
|
46293
|
2622 int count = SPECPDL_INDEX ();
|
14456
|
2623
|
|
2624 specbind (Qcursor_in_echo_area, Qt);
|
211
|
2625
|
2091
|
2626 map = Fsymbol_value (intern ("query-replace-map"));
|
|
2627
|
40656
|
2628 CHECK_STRING (prompt);
|
211
|
2629 xprompt = prompt;
|
|
2630 GCPRO2 (prompt, xprompt);
|
|
2631
|
93072
|
2632 #ifdef HAVE_WINDOW_SYSTEM
|
36256
e033d60bd048
Use display_hourglass_p, start_hourglass, cancel_hourglass instead of
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
2633 if (display_hourglass_p)
|
e033d60bd048
Use display_hourglass_p, start_hourglass, cancel_hourglass instead of
Gerd Moellmann <gerd@gnu.org>
diff
changeset
|
2634 cancel_hourglass ();
|
28072
|
2635 #endif
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
2636
|
211
|
2637 while (1)
|
|
2638 {
|
14456
|
2639
|
13862
|
2640 #ifdef HAVE_MENUS
|
83370
5272862a4865
Fix crashes in xdialog_show (and other places) with xterm-mouse-mode.
Karoly Lorentey <lorentey@elte.hu>
diff
changeset
|
2641 if (FRAME_WINDOW_P (SELECTED_FRAME ())
|
5272862a4865
Fix crashes in xdialog_show (and other places) with xterm-mouse-mode.
Karoly Lorentey <lorentey@elte.hu>
diff
changeset
|
2642 && (NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
|
18531
|
2643 && use_dialog_box
|
13862
|
2644 && have_menus_p ())
|
6057
|
2645 {
|
|
2646 Lisp_Object pane, menu;
|
35336
|
2647 redisplay_preserve_echo_area (3);
|
6057
|
2648 pane = Fcons (Fcons (build_string ("Yes"), Qt),
|
|
2649 Fcons (Fcons (build_string ("No"), Qnil),
|
|
2650 Qnil));
|
6478
|
2651 menu = Fcons (prompt, pane);
|
62674
|
2652 obj = Fx_popup_dialog (Qt, menu, Qnil);
|
6057
|
2653 answer = !NILP (obj);
|
|
2654 break;
|
|
2655 }
|
13862
|
2656 #endif /* HAVE_MENUS */
|
6850
|
2657 cursor_in_echo_area = 1;
|
14392
|
2658 choose_minibuf_frame ();
|
44524
|
2659
|
|
2660 {
|
|
2661 Lisp_Object pargs[3];
|
|
2662
|
45037
|
2663 /* Colorize prompt according to `minibuffer-prompt' face. */
|
44524
|
2664 pargs[0] = build_string ("%s(y or n) ");
|
|
2665 pargs[1] = intern ("face");
|
|
2666 pargs[2] = intern ("minibuffer-prompt");
|
|
2667 args[0] = Fpropertize (3, pargs);
|
|
2668 args[1] = xprompt;
|
|
2669 Fmessage (2, args);
|
|
2670 }
|
211
|
2671
|
16561
|
2672 if (minibuffer_auto_raise)
|
|
2673 {
|
|
2674 Lisp_Object mini_frame;
|
|
2675
|
|
2676 mini_frame = WINDOW_FRAME (XWINDOW (minibuf_window));
|
|
2677
|
|
2678 Fraise_frame (mini_frame);
|
|
2679 }
|
|
2680
|
83449
ff74a86c2b16
Overhaul and simplify single_kboard API. Allow calls to `recursive-edit' in process filters. Small fixes.
Karoly Lorentey <lorentey@elte.hu>
diff
changeset
|
2681 temporarily_switch_to_single_kboard (SELECTED_FRAME ());
|
72136
ff262d47a1dc
(Fy_or_n_p): Change call to read_filtered_event to use new arg.
Chong Yidong <cyd@stupidchicken.com>
diff
changeset
|
2682 obj = read_filtered_event (1, 0, 0, 0, Qnil);
|
6850
|
2683 cursor_in_echo_area = 0;
|
|
2684 /* If we need to quit, quit with cursor_in_echo_area = 0. */
|
|
2685 QUIT;
|
2369
|
2686
|
2091
|
2687 key = Fmake_vector (make_number (1), obj);
|
15713
|
2688 def = Flookup_key (map, key, Qt);
|
211
|
2689
|
2091
|
2690 if (EQ (def, intern ("skip")))
|
|
2691 {
|
|
2692 answer = 0;
|
|
2693 break;
|
|
2694 }
|
|
2695 else if (EQ (def, intern ("act")))
|
|
2696 {
|
|
2697 answer = 1;
|
|
2698 break;
|
|
2699 }
|
2311
|
2700 else if (EQ (def, intern ("recenter")))
|
|
2701 {
|
|
2702 Frecenter (Qnil);
|
|
2703 xprompt = prompt;
|
|
2704 continue;
|
|
2705 }
|
2091
|
2706 else if (EQ (def, intern ("quit")))
|
211
|
2707 Vquit_flag = Qt;
|
10059
|
2708 /* We want to exit this command for exit-prefix,
|
|
2709 and this is the only way to do it. */
|
|
2710 else if (EQ (def, intern ("exit-prefix")))
|
|
2711 Vquit_flag = Qt;
|
2091
|
2712
|
211
|
2713 QUIT;
|
1194
|
2714
|
|
2715 /* If we don't clear this, then the next call to read_char will
|
|
2716 return quit_char again, and we'll enter an infinite loop. */
|
1193
|
2717 Vquit_flag = Qnil;
|
211
|
2718
|
|
2719 Fding (Qnil);
|
|
2720 Fdiscard_input ();
|
|
2721 if (EQ (xprompt, prompt))
|
|
2722 {
|
|
2723 args[0] = build_string ("Please answer y or n. ");
|
|
2724 args[1] = prompt;
|
|
2725 xprompt = Fconcat (2, args);
|
|
2726 }
|
|
2727 }
|
|
2728 UNGCPRO;
|
2171
|
2729
|
2525
|
2730 if (! noninteractive)
|
|
2731 {
|
|
2732 cursor_in_echo_area = -1;
|
20607
|
2733 message_with_string (answer ? "%s(y or n) y" : "%s(y or n) n",
|
|
2734 xprompt, 0);
|
2525
|
2735 }
|
2171
|
2736
|
14456
|
2737 unbind_to (count, Qnil);
|
2091
|
2738 return answer ? Qt : Qnil;
|
211
|
2739 }
|
|
2740
|
|
2741 /* This is how C code calls `yes-or-no-p' and allows the user
|
|
2742 to redefined it.
|
|
2743
|
|
2744 Anything that calls this function must protect from GC! */
|
|
2745
|
|
2746 Lisp_Object
|
|
2747 do_yes_or_no_p (prompt)
|
|
2748 Lisp_Object prompt;
|
|
2749 {
|
|
2750 return call1 (intern ("yes-or-no-p"), prompt);
|
|
2751 }
|
|
2752
|
|
2753 /* Anything that calls this function must protect from GC! */
|
|
2754
|
|
2755 DEFUN ("yes-or-no-p", Fyes_or_no_p, Syes_or_no_p, 1, 1, 0,
|
39977
|
2756 doc: /* Ask user a yes-or-no question. Return t if answer is yes.
|
39899
|
2757 Takes one argument, which is the string to display to ask the question.
|
|
2758 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
|
|
2759 The user must confirm the answer with RET,
|
|
2760 and can edit it until it has been confirmed.
|
|
2761
|
|
2762 Under a windowing system a dialog box will be used if `last-nonmenu-event'
|
39977
|
2763 is nil, and `use-dialog-box' is non-nil. */)
|
|
2764 (prompt)
|
211
|
2765 Lisp_Object prompt;
|
|
2766 {
|
|
2767 register Lisp_Object ans;
|
|
2768 Lisp_Object args[2];
|
|
2769 struct gcpro gcpro1;
|
|
2770
|
40656
|
2771 CHECK_STRING (prompt);
|
211
|
2772
|
13862
|
2773 #ifdef HAVE_MENUS
|
83370
5272862a4865
Fix crashes in xdialog_show (and other places) with xterm-mouse-mode.
Karoly Lorentey <lorentey@elte.hu>
diff
changeset
|
2774 if (FRAME_WINDOW_P (SELECTED_FRAME ())
|
5272862a4865
Fix crashes in xdialog_show (and other places) with xterm-mouse-mode.
Karoly Lorentey <lorentey@elte.hu>
diff
changeset
|
2775 && (NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
|
18531
|
2776 && use_dialog_box
|
13862
|
2777 && have_menus_p ())
|
6057
|
2778 {
|
|
2779 Lisp_Object pane, menu, obj;
|
35336
|
2780 redisplay_preserve_echo_area (4);
|
6057
|
2781 pane = Fcons (Fcons (build_string ("Yes"), Qt),
|
|
2782 Fcons (Fcons (build_string ("No"), Qnil),
|
|
2783 Qnil));
|
|
2784 GCPRO1 (pane);
|
6478
|
2785 menu = Fcons (prompt, pane);
|
62674
|
2786 obj = Fx_popup_dialog (Qt, menu, Qnil);
|
6057
|
2787 UNGCPRO;
|
|
2788 return obj;
|
|
2789 }
|
13862
|
2790 #endif /* HAVE_MENUS */
|
6057
|
2791
|
211
|
2792 args[0] = prompt;
|
|
2793 args[1] = build_string ("(yes or no) ");
|
|
2794 prompt = Fconcat (2, args);
|
|
2795
|
|
2796 GCPRO1 (prompt);
|
6057
|
2797
|
211
|
2798 while (1)
|
|
2799 {
|
4456
|
2800 ans = Fdowncase (Fread_from_minibuffer (prompt, Qnil, Qnil, Qnil,
|
19542
|
2801 Qyes_or_no_p_history, Qnil,
|
70939
10be917a42fa
(Fyes_or_no_p): Fread_from_minibuffer now takes only seven args.
Luc Teirlinck <teirllm@auburn.edu>
diff
changeset
|
2802 Qnil));
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
2803 if (SCHARS (ans) == 3 && !strcmp (SDATA (ans), "yes"))
|
211
|
2804 {
|
|
2805 UNGCPRO;
|
|
2806 return Qt;
|
|
2807 }
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
2808 if (SCHARS (ans) == 2 && !strcmp (SDATA (ans), "no"))
|
211
|
2809 {
|
|
2810 UNGCPRO;
|
|
2811 return Qnil;
|
|
2812 }
|
|
2813
|
|
2814 Fding (Qnil);
|
|
2815 Fdiscard_input ();
|
|
2816 message ("Please answer yes or no.");
|
1045
|
2817 Fsleep_for (make_number (2), Qnil);
|
211
|
2818 }
|
|
2819 }
|
|
2820
|
21791
|
2821 DEFUN ("load-average", Fload_average, Sload_average, 0, 1, 0,
|
39977
|
2822 doc: /* Return list of 1 minute, 5 minute and 15 minute load averages.
|
49246
|
2823
|
39899
|
2824 Each of the three load averages is multiplied by 100, then converted
|
|
2825 to integer.
|
|
2826
|
|
2827 When USE-FLOATS is non-nil, floats will be used instead of integers.
|
|
2828 These floats are not multiplied by 100.
|
|
2829
|
|
2830 If the 5-minute or 15-minute load averages are not available, return a
|
51397
|
2831 shortened list, containing only those averages which are available.
|
|
2832
|
|
2833 An error is thrown if the load average can't be obtained. In some
|
|
2834 cases making it work would require Emacs being installed setuid or
|
|
2835 setgid so that it can read kernel information, and that usually isn't
|
|
2836 advisable. */)
|
39977
|
2837 (use_floats)
|
21791
|
2838 Lisp_Object use_floats;
|
211
|
2839 {
|
727
|
2840 double load_ave[3];
|
|
2841 int loads = getloadavg (load_ave, 3);
|
21791
|
2842 Lisp_Object ret = Qnil;
|
211
|
2843
|
727
|
2844 if (loads < 0)
|
|
2845 error ("load-average not implemented for this operating system");
|
211
|
2846
|
21791
|
2847 while (loads-- > 0)
|
|
2848 {
|
|
2849 Lisp_Object load = (NILP (use_floats) ?
|
|
2850 make_number ((int) (100.0 * load_ave[loads]))
|
|
2851 : make_float (load_ave[loads]));
|
|
2852 ret = Fcons (load, ret);
|
|
2853 }
|
211
|
2854
|
727
|
2855 return ret;
|
211
|
2856 }
|
|
2857
|
39968
|
2858 Lisp_Object Vfeatures, Qsubfeatures;
|
|
2859 extern Lisp_Object Vafter_load_alist;
|
39850
|
2860
|
|
2861 DEFUN ("featurep", Ffeaturep, Sfeaturep, 1, 2, 0,
|
39977
|
2862 doc: /* Returns t if FEATURE is present in this Emacs.
|
49246
|
2863
|
39899
|
2864 Use this to conditionalize execution of lisp code based on the
|
73686
|
2865 presence or absence of Emacs or environment extensions.
|
39899
|
2866 Use `provide' to declare that a feature is available. This function
|
|
2867 looks at the value of the variable `features'. The optional argument
|
39977
|
2868 SUBFEATURE can be used to check a specific subfeature of FEATURE. */)
|
|
2869 (feature, subfeature)
|
39850
|
2870 Lisp_Object feature, subfeature;
|
211
|
2871 {
|
|
2872 register Lisp_Object tem;
|
40656
|
2873 CHECK_SYMBOL (feature);
|
211
|
2874 tem = Fmemq (feature, Vfeatures);
|
39850
|
2875 if (!NILP (tem) && !NILP (subfeature))
|
44066
|
2876 tem = Fmember (subfeature, Fget (feature, Qsubfeatures));
|
485
|
2877 return (NILP (tem)) ? Qnil : Qt;
|
211
|
2878 }
|
|
2879
|
39850
|
2880 DEFUN ("provide", Fprovide, Sprovide, 1, 2, 0,
|
39977
|
2881 doc: /* Announce that FEATURE is a feature of the current Emacs.
|
39899
|
2882 The optional argument SUBFEATURES should be a list of symbols listing
|
39977
|
2883 particular subfeatures supported in this version of FEATURE. */)
|
|
2884 (feature, subfeatures)
|
39850
|
2885 Lisp_Object feature, subfeatures;
|
211
|
2886 {
|
|
2887 register Lisp_Object tem;
|
40656
|
2888 CHECK_SYMBOL (feature);
|
44066
|
2889 CHECK_LIST (subfeatures);
|
485
|
2890 if (!NILP (Vautoload_queue))
|
67809
|
2891 Vautoload_queue = Fcons (Fcons (make_number (0), Vfeatures),
|
|
2892 Vautoload_queue);
|
211
|
2893 tem = Fmemq (feature, Vfeatures);
|
485
|
2894 if (NILP (tem))
|
211
|
2895 Vfeatures = Fcons (feature, Vfeatures);
|
39850
|
2896 if (!NILP (subfeatures))
|
|
2897 Fput (feature, Qsubfeatures, subfeatures);
|
2546
|
2898 LOADHIST_ATTACH (Fcons (Qprovide, feature));
|
39850
|
2899
|
|
2900 /* Run any load-hooks for this file. */
|
|
2901 tem = Fassq (feature, Vafter_load_alist);
|
46221
|
2902 if (CONSP (tem))
|
|
2903 Fprogn (XCDR (tem));
|
39850
|
2904
|
211
|
2905 return feature;
|
|
2906 }
|
40474
|
2907
|
|
2908 /* `require' and its subroutines. */
|
|
2909
|
|
2910 /* List of features currently being require'd, innermost first. */
|
|
2911
|
|
2912 Lisp_Object require_nesting_list;
|
|
2913
|
40550
|
2914 Lisp_Object
|
40474
|
2915 require_unwind (old_value)
|
|
2916 Lisp_Object old_value;
|
|
2917 {
|
40550
|
2918 return require_nesting_list = old_value;
|
40474
|
2919 }
|
211
|
2920
|
23733
|
2921 DEFUN ("require", Frequire, Srequire, 1, 3, 0,
|
39977
|
2922 doc: /* If feature FEATURE is not loaded, load it from FILENAME.
|
39899
|
2923 If FEATURE is not a member of the list `features', then the feature
|
|
2924 is not loaded; so load the file FILENAME.
|
|
2925 If FILENAME is omitted, the printname of FEATURE is used as the file name,
|
52766
|
2926 and `load' will try to load this name appended with the suffix `.elc' or
|
|
2927 `.el', in that order. The name without appended suffix will not be used.
|
39899
|
2928 If the optional third argument NOERROR is non-nil,
|
|
2929 then return nil if the file is not found instead of signaling an error.
|
|
2930 Normally the return value is FEATURE.
|
39977
|
2931 The normal messages at start and end of loading FILENAME are suppressed. */)
|
|
2932 (feature, filename, noerror)
|
37208
|
2933 Lisp_Object feature, filename, noerror;
|
211
|
2934 {
|
|
2935 register Lisp_Object tem;
|
40474
|
2936 struct gcpro gcpro1, gcpro2;
|
67497
|
2937 int from_file = load_in_progress;
|
40474
|
2938
|
40656
|
2939 CHECK_SYMBOL (feature);
|
40474
|
2940
|
59490
|
2941 /* Record the presence of `require' in this file
|
61417
|
2942 even if the feature specified is already loaded.
|
|
2943 But not more than once in any file,
|
67497
|
2944 and not when we aren't loading or reading from a file. */
|
|
2945 if (!from_file)
|
|
2946 for (tem = Vcurrent_load_list; CONSP (tem); tem = XCDR (tem))
|
|
2947 if (NILP (XCDR (tem)) && STRINGP (XCAR (tem)))
|
|
2948 from_file = 1;
|
|
2949
|
|
2950 if (from_file)
|
61417
|
2951 {
|
|
2952 tem = Fcons (Qrequire, feature);
|
|
2953 if (NILP (Fmember (tem, Vcurrent_load_list)))
|
|
2954 LOADHIST_ATTACH (tem);
|
|
2955 }
|
211
|
2956 tem = Fmemq (feature, Vfeatures);
|
49246
|
2957
|
485
|
2958 if (NILP (tem))
|
211
|
2959 {
|
46293
|
2960 int count = SPECPDL_INDEX ();
|
40474
|
2961 int nesting = 0;
|
45037
|
2962
|
45039
|
2963 /* This is to make sure that loadup.el gives a clear picture
|
|
2964 of what files are preloaded and when. */
|
45037
|
2965 if (! NILP (Vpurify_flag))
|
|
2966 error ("(require %s) while preparing to dump",
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
2967 SDATA (SYMBOL_NAME (feature)));
|
49246
|
2968
|
40474
|
2969 /* A certain amount of recursive `require' is legitimate,
|
|
2970 but if we require the same feature recursively 3 times,
|
|
2971 signal an error. */
|
|
2972 tem = require_nesting_list;
|
|
2973 while (! NILP (tem))
|
|
2974 {
|
|
2975 if (! NILP (Fequal (feature, XCAR (tem))))
|
|
2976 nesting++;
|
|
2977 tem = XCDR (tem);
|
|
2978 }
|
48567
ecf43ac20827
fns.c (Frequire): Change nesting allowance from 2 to 3 to cause more
Steven Tamm <steventamm@mac.com>
diff
changeset
|
2979 if (nesting > 3)
|
40474
|
2980 error ("Recursive `require' for feature `%s'",
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
2981 SDATA (SYMBOL_NAME (feature)));
|
40474
|
2982
|
|
2983 /* Update the list for any nested `require's that occur. */
|
|
2984 record_unwind_protect (require_unwind, require_nesting_list);
|
|
2985 require_nesting_list = Fcons (feature, require_nesting_list);
|
211
|
2986
|
|
2987 /* Value saved here is to be restored into Vautoload_queue */
|
|
2988 record_unwind_protect (un_autoload, Vautoload_queue);
|
|
2989 Vautoload_queue = Qt;
|
|
2990
|
40474
|
2991 /* Load the file. */
|
|
2992 GCPRO2 (feature, filename);
|
37208
|
2993 tem = Fload (NILP (filename) ? Fsymbol_name (feature) : filename,
|
|
2994 noerror, Qt, Qnil, (NILP (filename) ? Qt : Qnil));
|
40474
|
2995 UNGCPRO;
|
|
2996
|
23733
|
2997 /* If load failed entirely, return nil. */
|
|
2998 if (NILP (tem))
|
24016
|
2999 return unbind_to (count, Qnil);
|
211
|
3000
|
|
3001 tem = Fmemq (feature, Vfeatures);
|
485
|
3002 if (NILP (tem))
|
40474
|
3003 error ("Required feature `%s' was not provided",
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
3004 SDATA (SYMBOL_NAME (feature)));
|
211
|
3005
|
|
3006 /* Once loading finishes, don't undo it. */
|
|
3007 Vautoload_queue = Qt;
|
|
3008 feature = unbind_to (count, feature);
|
|
3009 }
|
40474
|
3010
|
211
|
3011 return feature;
|
|
3012 }
|
|
3013
|
20004
|
3014 /* Primitives for work of the "widget" library.
|
|
3015 In an ideal world, this section would not have been necessary.
|
|
3016 However, lisp function calls being as slow as they are, it turns
|
|
3017 out that some functions in the widget library (wid-edit.el) are the
|
|
3018 bottleneck of Widget operation. Here is their translation to C,
|
|
3019 for the sole reason of efficiency. */
|
|
3020
|
29953
|
3021 DEFUN ("plist-member", Fplist_member, Splist_member, 2, 2, 0,
|
39977
|
3022 doc: /* Return non-nil if PLIST has the property PROP.
|
39899
|
3023 PLIST is a property list, which is a list of the form
|
|
3024 \(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol.
|
|
3025 Unlike `plist-get', this allows you to distinguish between a missing
|
|
3026 property and a property with the value nil.
|
39977
|
3027 The value is actually the tail of PLIST whose car is PROP. */)
|
|
3028 (plist, prop)
|
20004
|
3029 Lisp_Object plist, prop;
|
|
3030 {
|
|
3031 while (CONSP (plist) && !EQ (XCAR (plist), prop))
|
|
3032 {
|
|
3033 QUIT;
|
|
3034 plist = XCDR (plist);
|
|
3035 plist = CDR (plist);
|
|
3036 }
|
|
3037 return plist;
|
|
3038 }
|
|
3039
|
|
3040 DEFUN ("widget-put", Fwidget_put, Swidget_put, 3, 3, 0,
|
39977
|
3041 doc: /* In WIDGET, set PROPERTY to VALUE.
|
|
3042 The value can later be retrieved with `widget-get'. */)
|
|
3043 (widget, property, value)
|
20004
|
3044 Lisp_Object widget, property, value;
|
|
3045 {
|
40656
|
3046 CHECK_CONS (widget);
|
39973
579177964efa
Avoid (most) uses of XCAR/XCDR as lvalues, for flexibility in experimenting
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
3047 XSETCDR (widget, Fplist_put (XCDR (widget), property, value));
|
23207
|
3048 return value;
|
20004
|
3049 }
|
|
3050
|
|
3051 DEFUN ("widget-get", Fwidget_get, Swidget_get, 2, 2, 0,
|
39977
|
3052 doc: /* In WIDGET, get the value of PROPERTY.
|
39899
|
3053 The value could either be specified when the widget was created, or
|
39977
|
3054 later with `widget-put'. */)
|
|
3055 (widget, property)
|
20004
|
3056 Lisp_Object widget, property;
|
|
3057 {
|
|
3058 Lisp_Object tmp;
|
|
3059
|
|
3060 while (1)
|
|
3061 {
|
|
3062 if (NILP (widget))
|
|
3063 return Qnil;
|
40656
|
3064 CHECK_CONS (widget);
|
29953
|
3065 tmp = Fplist_member (XCDR (widget), property);
|
20004
|
3066 if (CONSP (tmp))
|
|
3067 {
|
|
3068 tmp = XCDR (tmp);
|
|
3069 return CAR (tmp);
|
|
3070 }
|
|
3071 tmp = XCAR (widget);
|
|
3072 if (NILP (tmp))
|
|
3073 return Qnil;
|
|
3074 widget = Fget (tmp, Qwidget_type);
|
|
3075 }
|
|
3076 }
|
|
3077
|
|
3078 DEFUN ("widget-apply", Fwidget_apply, Swidget_apply, 2, MANY, 0,
|
39977
|
3079 doc: /* Apply the value of WIDGET's PROPERTY to the widget itself.
|
40132
75fe73bea452
(Fappend, Fconcat, Fvconcat, Fnconc, Fwidget_apply, Fmake_hash_table):
Miles Bader <miles@gnu.org>
diff
changeset
|
3080 ARGS are passed as extra arguments to the function.
|
75fe73bea452
(Fappend, Fconcat, Fvconcat, Fnconc, Fwidget_apply, Fmake_hash_table):
Miles Bader <miles@gnu.org>
diff
changeset
|
3081 usage: (widget-apply WIDGET PROPERTY &rest ARGS) */)
|
39977
|
3082 (nargs, args)
|
20004
|
3083 int nargs;
|
|
3084 Lisp_Object *args;
|
|
3085 {
|
|
3086 /* This function can GC. */
|
|
3087 Lisp_Object newargs[3];
|
|
3088 struct gcpro gcpro1, gcpro2;
|
|
3089 Lisp_Object result;
|
|
3090
|
|
3091 newargs[0] = Fwidget_get (args[0], args[1]);
|
|
3092 newargs[1] = args[0];
|
|
3093 newargs[2] = Flist (nargs - 2, args + 2);
|
|
3094 GCPRO2 (newargs[0], newargs[2]);
|
|
3095 result = Fapply (3, newargs);
|
|
3096 UNGCPRO;
|
|
3097 return result;
|
|
3098 }
|
49081
|
3099
|
|
3100 #ifdef HAVE_LANGINFO_CODESET
|
|
3101 #include <langinfo.h>
|
|
3102 #endif
|
|
3103
|
51976
|
3104 DEFUN ("locale-info", Flocale_info, Slocale_info, 1, 1, 0,
|
|
3105 doc: /* Access locale data ITEM for the current C locale, if available.
|
|
3106 ITEM should be one of the following:
|
51397
|
3107
|
49798
|
3108 `codeset', returning the character set as a string (locale item CODESET);
|
51397
|
3109
|
49798
|
3110 `days', returning a 7-element vector of day names (locale items DAY_n);
|
51397
|
3111
|
49798
|
3112 `months', returning a 12-element vector of month names (locale items MON_n);
|
51397
|
3113
|
51976
|
3114 `paper', returning a list (WIDTH HEIGHT) for the default paper size,
|
|
3115 both measured in milimeters (locale items PAPER_WIDTH, PAPER_HEIGHT).
|
49081
|
3116
|
|
3117 If the system can't provide such information through a call to
|
51976
|
3118 `nl_langinfo', or if ITEM isn't from the list above, return nil.
|
49081
|
3119
|
49798
|
3120 See also Info node `(libc)Locales'.
|
|
3121
|
49081
|
3122 The data read from the system are decoded using `locale-coding-system'. */)
|
|
3123 (item)
|
|
3124 Lisp_Object item;
|
|
3125 {
|
|
3126 char *str = NULL;
|
|
3127 #ifdef HAVE_LANGINFO_CODESET
|
|
3128 Lisp_Object val;
|
|
3129 if (EQ (item, Qcodeset))
|
|
3130 {
|
|
3131 str = nl_langinfo (CODESET);
|
|
3132 return build_string (str);
|
|
3133 }
|
|
3134 #ifdef DAY_1
|
|
3135 else if (EQ (item, Qdays)) /* e.g. for calendar-day-name-array */
|
|
3136 {
|
|
3137 Lisp_Object v = Fmake_vector (make_number (7), Qnil);
|
|
3138 int days[7] = {DAY_1, DAY_2, DAY_3, DAY_4, DAY_5, DAY_6, DAY_7};
|
|
3139 int i;
|
|
3140 synchronize_system_time_locale ();
|
|
3141 for (i = 0; i < 7; i++)
|
|
3142 {
|
|
3143 str = nl_langinfo (days[i]);
|
|
3144 val = make_unibyte_string (str, strlen (str));
|
|
3145 /* Fixme: Is this coding system necessarily right, even if
|
|
3146 it is consistent with CODESET? If not, what to do? */
|
|
3147 Faset (v, make_number (i),
|
|
3148 code_convert_string_norecord (val, Vlocale_coding_system,
|
49915
|
3149 0));
|
49081
|
3150 }
|
|
3151 return v;
|
|
3152 }
|
|
3153 #endif /* DAY_1 */
|
|
3154 #ifdef MON_1
|
|
3155 else if (EQ (item, Qmonths)) /* e.g. for calendar-month-name-array */
|
|
3156 {
|
|
3157 struct Lisp_Vector *p = allocate_vector (12);
|
|
3158 int months[12] = {MON_1, MON_2, MON_3, MON_4, MON_5, MON_6, MON_7,
|
|
3159 MON_8, MON_9, MON_10, MON_11, MON_12};
|
|
3160 int i;
|
|
3161 synchronize_system_time_locale ();
|
|
3162 for (i = 0; i < 12; i++)
|
|
3163 {
|
|
3164 str = nl_langinfo (months[i]);
|
|
3165 val = make_unibyte_string (str, strlen (str));
|
|
3166 p->contents[i] =
|
49915
|
3167 code_convert_string_norecord (val, Vlocale_coding_system, 0);
|
49081
|
3168 }
|
|
3169 XSETVECTOR (val, p);
|
|
3170 return val;
|
|
3171 }
|
|
3172 #endif /* MON_1 */
|
|
3173 /* LC_PAPER stuff isn't defined as accessible in glibc as of 2.3.1,
|
|
3174 but is in the locale files. This could be used by ps-print. */
|
|
3175 #ifdef PAPER_WIDTH
|
|
3176 else if (EQ (item, Qpaper))
|
|
3177 {
|
|
3178 return list2 (make_number (nl_langinfo (PAPER_WIDTH)),
|
|
3179 make_number (nl_langinfo (PAPER_HEIGHT)));
|
|
3180 }
|
|
3181 #endif /* PAPER_WIDTH */
|
|
3182 #endif /* HAVE_LANGINFO_CODESET*/
|
51397
|
3183 return Qnil;
|
49081
|
3184 }
|
20004
|
3185
|
32234
|
3186 /* base64 encode/decode functions (RFC 2045).
|
23208
|
3187 Based on code from GNU recode. */
|
|
3188
|
|
3189 #define MIME_LINE_LENGTH 76
|
|
3190
|
|
3191 #define IS_ASCII(Character) \
|
|
3192 ((Character) < 128)
|
|
3193 #define IS_BASE64(Character) \
|
|
3194 (IS_ASCII (Character) && base64_char_to_value[Character] >= 0)
|
24275
|
3195 #define IS_BASE64_IGNORABLE(Character) \
|
|
3196 ((Character) == ' ' || (Character) == '\t' || (Character) == '\n' \
|
|
3197 || (Character) == '\f' || (Character) == '\r')
|
|
3198
|
|
3199 /* Used by base64_decode_1 to retrieve a non-base64-ignorable
|
|
3200 character or return retval if there are no characters left to
|
|
3201 process. */
|
32351
|
3202 #define READ_QUADRUPLET_BYTE(retval) \
|
|
3203 do \
|
|
3204 { \
|
|
3205 if (i == length) \
|
|
3206 { \
|
|
3207 if (nchars_return) \
|
|
3208 *nchars_return = nchars; \
|
|
3209 return (retval); \
|
|
3210 } \
|
|
3211 c = from[i++]; \
|
|
3212 } \
|
24275
|
3213 while (IS_BASE64_IGNORABLE (c))
|
23208
|
3214
|
|
3215 /* Table of characters coding the 64 values. */
|
|
3216 static char base64_value_to_char[64] =
|
|
3217 {
|
|
3218 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', /* 0- 9 */
|
|
3219 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', /* 10-19 */
|
|
3220 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', /* 20-29 */
|
|
3221 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', /* 30-39 */
|
|
3222 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', /* 40-49 */
|
|
3223 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', /* 50-59 */
|
|
3224 '8', '9', '+', '/' /* 60-63 */
|
|
3225 };
|
|
3226
|
|
3227 /* Table of base64 values for first 128 characters. */
|
|
3228 static short base64_char_to_value[128] =
|
|
3229 {
|
|
3230 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0- 9 */
|
|
3231 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10- 19 */
|
|
3232 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20- 29 */
|
|
3233 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 30- 39 */
|
|
3234 -1, -1, -1, 62, -1, -1, -1, 63, 52, 53, /* 40- 49 */
|
|
3235 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, /* 50- 59 */
|
|
3236 -1, -1, -1, -1, -1, 0, 1, 2, 3, 4, /* 60- 69 */
|
|
3237 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 70- 79 */
|
|
3238 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, /* 80- 89 */
|
|
3239 25, -1, -1, -1, -1, -1, -1, 26, 27, 28, /* 90- 99 */
|
|
3240 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, /* 100-109 */
|
|
3241 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, /* 110-119 */
|
|
3242 49, 50, 51, -1, -1, -1, -1, -1 /* 120-127 */
|
|
3243 };
|
|
3244
|
|
3245 /* The following diagram shows the logical steps by which three octets
|
|
3246 get transformed into four base64 characters.
|
|
3247
|
|
3248 .--------. .--------. .--------.
|
|
3249 |aaaaaabb| |bbbbcccc| |ccdddddd|
|
|
3250 `--------' `--------' `--------'
|
|
3251 6 2 4 4 2 6
|
|
3252 .--------+--------+--------+--------.
|
|
3253 |00aaaaaa|00bbbbbb|00cccccc|00dddddd|
|
|
3254 `--------+--------+--------+--------'
|
|
3255
|
|
3256 .--------+--------+--------+--------.
|
|
3257 |AAAAAAAA|BBBBBBBB|CCCCCCCC|DDDDDDDD|
|
|
3258 `--------+--------+--------+--------'
|
|
3259
|
|
3260 The octets are divided into 6 bit chunks, which are then encoded into
|
|
3261 base64 characters. */
|
|
3262
|
|
3263
|
29010
|
3264 static int base64_encode_1 P_ ((const char *, char *, int, int, int));
|
32351
|
3265 static int base64_decode_1 P_ ((const char *, char *, int, int, int *));
|
23208
|
3266
|
|
3267 DEFUN ("base64-encode-region", Fbase64_encode_region, Sbase64_encode_region,
|
|
3268 2, 3, "r",
|
39977
|
3269 doc: /* Base64-encode the region between BEG and END.
|
39899
|
3270 Return the length of the encoded text.
|
|
3271 Optional third argument NO-LINE-BREAK means do not break long lines
|
39977
|
3272 into shorter lines. */)
|
|
3273 (beg, end, no_line_break)
|
23208
|
3274 Lisp_Object beg, end, no_line_break;
|
|
3275 {
|
|
3276 char *encoded;
|
|
3277 int allength, length;
|
|
3278 int ibeg, iend, encoded_length;
|
|
3279 int old_pos = PT;
|
56195
|
3280 USE_SAFE_ALLOCA;
|
23208
|
3281
|
|
3282 validate_region (&beg, &end);
|
|
3283
|
|
3284 ibeg = CHAR_TO_BYTE (XFASTINT (beg));
|
|
3285 iend = CHAR_TO_BYTE (XFASTINT (end));
|
|
3286 move_gap_both (XFASTINT (beg), ibeg);
|
|
3287
|
|
3288 /* We need to allocate enough room for encoding the text.
|
|
3289 We need 33 1/3% more space, plus a newline every 76
|
|
3290 characters, and then we round up. */
|
|
3291 length = iend - ibeg;
|
|
3292 allength = length + length/3 + 1;
|
|
3293 allength += allength / MIME_LINE_LENGTH + 1 + 6;
|
|
3294
|
56195
|
3295 SAFE_ALLOCA (encoded, char *, allength);
|
23208
|
3296 encoded_length = base64_encode_1 (BYTE_POS_ADDR (ibeg), encoded, length,
|
29010
|
3297 NILP (no_line_break),
|
|
3298 !NILP (current_buffer->enable_multibyte_characters));
|
23208
|
3299 if (encoded_length > allength)
|
|
3300 abort ();
|
|
3301
|
29010
|
3302 if (encoded_length < 0)
|
|
3303 {
|
|
3304 /* The encoding wasn't possible. */
|
57726
|
3305 SAFE_FREE ();
|
32234
|
3306 error ("Multibyte character in data for base64 encoding");
|
29010
|
3307 }
|
|
3308
|
23208
|
3309 /* Now we have encoded the region, so we insert the new contents
|
|
3310 and delete the old. (Insert first in order to preserve markers.) */
|
23579
|
3311 SET_PT_BOTH (XFASTINT (beg), ibeg);
|
23208
|
3312 insert (encoded, encoded_length);
|
57726
|
3313 SAFE_FREE ();
|
23208
|
3314 del_range_byte (ibeg + encoded_length, iend + encoded_length, 1);
|
|
3315
|
|
3316 /* If point was outside of the region, restore it exactly; else just
|
|
3317 move to the beginning of the region. */
|
|
3318 if (old_pos >= XFASTINT (end))
|
|
3319 old_pos += encoded_length - (XFASTINT (end) - XFASTINT (beg));
|
23579
|
3320 else if (old_pos > XFASTINT (beg))
|
|
3321 old_pos = XFASTINT (beg);
|
23208
|
3322 SET_PT (old_pos);
|
|
3323
|
|
3324 /* We return the length of the encoded text. */
|
|
3325 return make_number (encoded_length);
|
|
3326 }
|
|
3327
|
|
3328 DEFUN ("base64-encode-string", Fbase64_encode_string, Sbase64_encode_string,
|
24334
|
3329 1, 2, 0,
|
39977
|
3330 doc: /* Base64-encode STRING and return the result.
|
39899
|
3331 Optional second argument NO-LINE-BREAK means do not break long lines
|
39977
|
3332 into shorter lines. */)
|
|
3333 (string, no_line_break)
|
24377
|
3334 Lisp_Object string, no_line_break;
|
23208
|
3335 {
|
|
3336 int allength, length, encoded_length;
|
|
3337 char *encoded;
|
23690
|
3338 Lisp_Object encoded_string;
|
56195
|
3339 USE_SAFE_ALLOCA;
|
23208
|
3340
|
40656
|
3341 CHECK_STRING (string);
|
23208
|
3342
|
24437
|
3343 /* We need to allocate enough room for encoding the text.
|
|
3344 We need 33 1/3% more space, plus a newline every 76
|
|
3345 characters, and then we round up. */
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
3346 length = SBYTES (string);
|
24437
|
3347 allength = length + length/3 + 1;
|
|
3348 allength += allength / MIME_LINE_LENGTH + 1 + 6;
|
23208
|
3349
|
|
3350 /* We need to allocate enough room for decoding the text. */
|
56195
|
3351 SAFE_ALLOCA (encoded, char *, allength);
|
23208
|
3352
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
3353 encoded_length = base64_encode_1 (SDATA (string),
|
29010
|
3354 encoded, length, NILP (no_line_break),
|
|
3355 STRING_MULTIBYTE (string));
|
23208
|
3356 if (encoded_length > allength)
|
|
3357 abort ();
|
|
3358
|
29010
|
3359 if (encoded_length < 0)
|
|
3360 {
|
|
3361 /* The encoding wasn't possible. */
|
57726
|
3362 SAFE_FREE ();
|
32234
|
3363 error ("Multibyte character in data for base64 encoding");
|
29010
|
3364 }
|
|
3365
|
23690
|
3366 encoded_string = make_unibyte_string (encoded, encoded_length);
|
57726
|
3367 SAFE_FREE ();
|
23690
|
3368
|
|
3369 return encoded_string;
|
23208
|
3370 }
|
|
3371
|
|
3372 static int
|
29010
|
3373 base64_encode_1 (from, to, length, line_break, multibyte)
|
23208
|
3374 const char *from;
|
|
3375 char *to;
|
|
3376 int length;
|
|
3377 int line_break;
|
29010
|
3378 int multibyte;
|
23208
|
3379 {
|
|
3380 int counter = 0, i = 0;
|
|
3381 char *e = to;
|
31865
|
3382 int c;
|
23208
|
3383 unsigned int value;
|
29010
|
3384 int bytes;
|
23208
|
3385
|
|
3386 while (i < length)
|
|
3387 {
|
29010
|
3388 if (multibyte)
|
|
3389 {
|
|
3390 c = STRING_CHAR_AND_LENGTH (from + i, length - i, bytes);
|
89046
|
3391 if (CHAR_BYTE8_P (c))
|
|
3392 c = CHAR_TO_BYTE8 (c);
|
|
3393 else if (c >= 256)
|
29010
|
3394 return -1;
|
32351
|
3395 i += bytes;
|
29010
|
3396 }
|
|
3397 else
|
|
3398 c = from[i++];
|
23208
|
3399
|
|
3400 /* Wrap line every 76 characters. */
|
|
3401
|
|
3402 if (line_break)
|
|
3403 {
|
|
3404 if (counter < MIME_LINE_LENGTH / 4)
|
|
3405 counter++;
|
|
3406 else
|
|
3407 {
|
|
3408 *e++ = '\n';
|
|
3409 counter = 1;
|
|
3410 }
|
|
3411 }
|
|
3412
|
|
3413 /* Process first byte of a triplet. */
|
|
3414
|
|
3415 *e++ = base64_value_to_char[0x3f & c >> 2];
|
|
3416 value = (0x03 & c) << 4;
|
|
3417
|
|
3418 /* Process second byte of a triplet. */
|
|
3419
|
|
3420 if (i == length)
|
|
3421 {
|
|
3422 *e++ = base64_value_to_char[value];
|
|
3423 *e++ = '=';
|
|
3424 *e++ = '=';
|
|
3425 break;
|
|
3426 }
|
|
3427
|
29010
|
3428 if (multibyte)
|
|
3429 {
|
|
3430 c = STRING_CHAR_AND_LENGTH (from + i, length - i, bytes);
|
89046
|
3431 if (CHAR_BYTE8_P (c))
|
|
3432 c = CHAR_TO_BYTE8 (c);
|
|
3433 else if (c >= 256)
|
31865
|
3434 return -1;
|
32351
|
3435 i += bytes;
|
29010
|
3436 }
|
|
3437 else
|
|
3438 c = from[i++];
|
23208
|
3439
|
|
3440 *e++ = base64_value_to_char[value | (0x0f & c >> 4)];
|
|
3441 value = (0x0f & c) << 2;
|
|
3442
|
|
3443 /* Process third byte of a triplet. */
|
|
3444
|
|
3445 if (i == length)
|
|
3446 {
|
|
3447 *e++ = base64_value_to_char[value];
|
|
3448 *e++ = '=';
|
|
3449 break;
|
|
3450 }
|
|
3451
|
29010
|
3452 if (multibyte)
|
|
3453 {
|
|
3454 c = STRING_CHAR_AND_LENGTH (from + i, length - i, bytes);
|
89046
|
3455 if (CHAR_BYTE8_P (c))
|
|
3456 c = CHAR_TO_BYTE8 (c);
|
|
3457 else if (c >= 256)
|
31865
|
3458 return -1;
|
32351
|
3459 i += bytes;
|
29010
|
3460 }
|
|
3461 else
|
|
3462 c = from[i++];
|
23208
|
3463
|
|
3464 *e++ = base64_value_to_char[value | (0x03 & c >> 6)];
|
|
3465 *e++ = base64_value_to_char[0x3f & c];
|
|
3466 }
|
|
3467
|
|
3468 return e - to;
|
|
3469 }
|
|
3470
|
|
3471
|
|
3472 DEFUN ("base64-decode-region", Fbase64_decode_region, Sbase64_decode_region,
|
39899
|
3473 2, 2, "r",
|
39977
|
3474 doc: /* Base64-decode the region between BEG and END.
|
39899
|
3475 Return the length of the decoded text.
|
39977
|
3476 If the region can't be decoded, signal an error and don't modify the buffer. */)
|
|
3477 (beg, end)
|
23208
|
3478 Lisp_Object beg, end;
|
|
3479 {
|
32351
|
3480 int ibeg, iend, length, allength;
|
23208
|
3481 char *decoded;
|
|
3482 int old_pos = PT;
|
|
3483 int decoded_length;
|
23536
|
3484 int inserted_chars;
|
32351
|
3485 int multibyte = !NILP (current_buffer->enable_multibyte_characters);
|
56195
|
3486 USE_SAFE_ALLOCA;
|
23208
|
3487
|
|
3488 validate_region (&beg, &end);
|
|
3489
|
|
3490 ibeg = CHAR_TO_BYTE (XFASTINT (beg));
|
|
3491 iend = CHAR_TO_BYTE (XFASTINT (end));
|
|
3492
|
|
3493 length = iend - ibeg;
|
32351
|
3494
|
|
3495 /* We need to allocate enough room for decoding the text. If we are
|
|
3496 working on a multibyte buffer, each decoded code may occupy at
|
|
3497 most two bytes. */
|
|
3498 allength = multibyte ? length * 2 : length;
|
56195
|
3499 SAFE_ALLOCA (decoded, char *, allength);
|
23208
|
3500
|
|
3501 move_gap_both (XFASTINT (beg), ibeg);
|
32351
|
3502 decoded_length = base64_decode_1 (BYTE_POS_ADDR (ibeg), decoded, length,
|
|
3503 multibyte, &inserted_chars);
|
|
3504 if (decoded_length > allength)
|
23208
|
3505 abort ();
|
|
3506
|
|
3507 if (decoded_length < 0)
|
23901
|
3508 {
|
|
3509 /* The decoding wasn't possible. */
|
57726
|
3510 SAFE_FREE ();
|
32234
|
3511 error ("Invalid base64 data");
|
23901
|
3512 }
|
23208
|
3513
|
|
3514 /* Now we have decoded the region, so we insert the new contents
|
|
3515 and delete the old. (Insert first in order to preserve markers.) */
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
3516 TEMP_SET_PT_BOTH (XFASTINT (beg), ibeg);
|
29010
|
3517 insert_1_both (decoded, inserted_chars, decoded_length, 0, 1, 0);
|
57726
|
3518 SAFE_FREE ();
|
56195
|
3519
|
29010
|
3520 /* Delete the original text. */
|
|
3521 del_range_both (PT, PT_BYTE, XFASTINT (end) + inserted_chars,
|
|
3522 iend + decoded_length, 1);
|
23208
|
3523
|
|
3524 /* If point was outside of the region, restore it exactly; else just
|
|
3525 move to the beginning of the region. */
|
|
3526 if (old_pos >= XFASTINT (end))
|
23536
|
3527 old_pos += inserted_chars - (XFASTINT (end) - XFASTINT (beg));
|
|
3528 else if (old_pos > XFASTINT (beg))
|
|
3529 old_pos = XFASTINT (beg);
|
25607
|
3530 SET_PT (old_pos > ZV ? ZV : old_pos);
|
23208
|
3531
|
23536
|
3532 return make_number (inserted_chars);
|
23208
|
3533 }
|
|
3534
|
|
3535 DEFUN ("base64-decode-string", Fbase64_decode_string, Sbase64_decode_string,
|
|
3536 1, 1, 0,
|
39977
|
3537 doc: /* Base64-decode STRING and return the result. */)
|
|
3538 (string)
|
23208
|
3539 Lisp_Object string;
|
|
3540 {
|
|
3541 char *decoded;
|
|
3542 int length, decoded_length;
|
23690
|
3543 Lisp_Object decoded_string;
|
56195
|
3544 USE_SAFE_ALLOCA;
|
23208
|
3545
|
40656
|
3546 CHECK_STRING (string);
|
23208
|
3547
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
3548 length = SBYTES (string);
|
23208
|
3549 /* We need to allocate enough room for decoding the text. */
|
56195
|
3550 SAFE_ALLOCA (decoded, char *, length);
|
23208
|
3551
|
32753
|
3552 /* The decoded result should be unibyte. */
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
3553 decoded_length = base64_decode_1 (SDATA (string), decoded, length,
|
32753
|
3554 0, NULL);
|
23208
|
3555 if (decoded_length > length)
|
|
3556 abort ();
|
28493
|
3557 else if (decoded_length >= 0)
|
29010
|
3558 decoded_string = make_unibyte_string (decoded, decoded_length);
|
28493
|
3559 else
|
23901
|
3560 decoded_string = Qnil;
|
|
3561
|
57726
|
3562 SAFE_FREE ();
|
28493
|
3563 if (!STRINGP (decoded_string))
|
32234
|
3564 error ("Invalid base64 data");
|
23690
|
3565
|
|
3566 return decoded_string;
|
23208
|
3567 }
|
|
3568
|
32351
|
3569 /* Base64-decode the data at FROM of LENGHT bytes into TO. If
|
|
3570 MULTIBYTE is nonzero, the decoded result should be in multibyte
|
|
3571 form. If NCHARS_RETRUN is not NULL, store the number of produced
|
|
3572 characters in *NCHARS_RETURN. */
|
|
3573
|
23208
|
3574 static int
|
32351
|
3575 base64_decode_1 (from, to, length, multibyte, nchars_return)
|
23208
|
3576 const char *from;
|
|
3577 char *to;
|
|
3578 int length;
|
32351
|
3579 int multibyte;
|
|
3580 int *nchars_return;
|
23208
|
3581 {
|
24275
|
3582 int i = 0;
|
23208
|
3583 char *e = to;
|
|
3584 unsigned char c;
|
|
3585 unsigned long value;
|
32351
|
3586 int nchars = 0;
|
23208
|
3587
|
24275
|
3588 while (1)
|
23208
|
3589 {
|
24275
|
3590 /* Process first byte of a quadruplet. */
|
|
3591
|
|
3592 READ_QUADRUPLET_BYTE (e-to);
|
23208
|
3593
|
|
3594 if (!IS_BASE64 (c))
|
|
3595 return -1;
|
|
3596 value = base64_char_to_value[c] << 18;
|
|
3597
|
|
3598 /* Process second byte of a quadruplet. */
|
|
3599
|
24275
|
3600 READ_QUADRUPLET_BYTE (-1);
|
23208
|
3601
|
|
3602 if (!IS_BASE64 (c))
|
|
3603 return -1;
|
|
3604 value |= base64_char_to_value[c] << 12;
|
|
3605
|
32351
|
3606 c = (unsigned char) (value >> 16);
|
89039
|
3607 if (multibyte && c >= 128)
|
|
3608 e += BYTE8_STRING (c, e);
|
32351
|
3609 else
|
|
3610 *e++ = c;
|
|
3611 nchars++;
|
23208
|
3612
|
|
3613 /* Process third byte of a quadruplet. */
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
3614
|
24275
|
3615 READ_QUADRUPLET_BYTE (-1);
|
23208
|
3616
|
|
3617 if (c == '=')
|
|
3618 {
|
24275
|
3619 READ_QUADRUPLET_BYTE (-1);
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
3620
|
23208
|
3621 if (c != '=')
|
|
3622 return -1;
|
|
3623 continue;
|
|
3624 }
|
|
3625
|
|
3626 if (!IS_BASE64 (c))
|
|
3627 return -1;
|
|
3628 value |= base64_char_to_value[c] << 6;
|
|
3629
|
32351
|
3630 c = (unsigned char) (0xff & value >> 8);
|
89039
|
3631 if (multibyte && c >= 128)
|
|
3632 e += BYTE8_STRING (c, e);
|
32351
|
3633 else
|
|
3634 *e++ = c;
|
|
3635 nchars++;
|
23208
|
3636
|
|
3637 /* Process fourth byte of a quadruplet. */
|
|
3638
|
24275
|
3639 READ_QUADRUPLET_BYTE (-1);
|
23208
|
3640
|
|
3641 if (c == '=')
|
|
3642 continue;
|
|
3643
|
|
3644 if (!IS_BASE64 (c))
|
|
3645 return -1;
|
|
3646 value |= base64_char_to_value[c];
|
|
3647
|
32351
|
3648 c = (unsigned char) (0xff & value);
|
89039
|
3649 if (multibyte && c >= 128)
|
|
3650 e += BYTE8_STRING (c, e);
|
32351
|
3651 else
|
|
3652 *e++ = c;
|
|
3653 nchars++;
|
23208
|
3654 }
|
|
3655 }
|
25005
|
3656
|
|
3657
|
|
3658
|
|
3659 /***********************************************************************
|
|
3660 ***** *****
|
|
3661 ***** Hash Tables *****
|
|
3662 ***** *****
|
|
3663 ***********************************************************************/
|
|
3664
|
|
3665 /* Implemented by gerd@gnu.org. This hash table implementation was
|
|
3666 inspired by CMUCL hash tables. */
|
|
3667
|
|
3668 /* Ideas:
|
|
3669
|
|
3670 1. For small tables, association lists are probably faster than
|
|
3671 hash tables because they have lower overhead.
|
|
3672
|
|
3673 For uses of hash tables where the O(1) behavior of table
|
|
3674 operations is not a requirement, it might therefore be a good idea
|
|
3675 not to hash. Instead, we could just do a linear search in the
|
|
3676 key_and_value vector of the hash table. This could be done
|
|
3677 if a `:linear-search t' argument is given to make-hash-table. */
|
|
3678
|
|
3679
|
|
3680 /* The list of all weak hash tables. Don't staticpro this one. */
|
|
3681
|
81813
32d8fd242bb2
* lisp.h (struct Lisp_Hash_Table): Turn next_weak into a bare pointer.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
3682 struct Lisp_Hash_Table *weak_hash_tables;
|
25005
|
3683
|
|
3684 /* Various symbols. */
|
|
3685
|
25365
|
3686 Lisp_Object Qhash_table_p, Qeq, Qeql, Qequal, Qkey, Qvalue;
|
25455
|
3687 Lisp_Object QCtest, QCsize, QCrehash_size, QCrehash_threshold, QCweakness;
|
30496
|
3688 Lisp_Object Qhash_table_test, Qkey_or_value, Qkey_and_value;
|
25005
|
3689
|
|
3690 /* Function prototypes. */
|
|
3691
|
|
3692 static struct Lisp_Hash_Table *check_hash_table P_ ((Lisp_Object));
|
|
3693 static int get_key_arg P_ ((Lisp_Object, int, Lisp_Object *, char *));
|
|
3694 static void maybe_resize_hash_table P_ ((struct Lisp_Hash_Table *));
|
|
3695 static int cmpfn_eql P_ ((struct Lisp_Hash_Table *, Lisp_Object, unsigned,
|
|
3696 Lisp_Object, unsigned));
|
|
3697 static int cmpfn_equal P_ ((struct Lisp_Hash_Table *, Lisp_Object, unsigned,
|
|
3698 Lisp_Object, unsigned));
|
|
3699 static int cmpfn_user_defined P_ ((struct Lisp_Hash_Table *, Lisp_Object,
|
|
3700 unsigned, Lisp_Object, unsigned));
|
|
3701 static unsigned hashfn_eq P_ ((struct Lisp_Hash_Table *, Lisp_Object));
|
|
3702 static unsigned hashfn_eql P_ ((struct Lisp_Hash_Table *, Lisp_Object));
|
|
3703 static unsigned hashfn_equal P_ ((struct Lisp_Hash_Table *, Lisp_Object));
|
|
3704 static unsigned hashfn_user_defined P_ ((struct Lisp_Hash_Table *,
|
|
3705 Lisp_Object));
|
|
3706 static unsigned sxhash_string P_ ((unsigned char *, int));
|
|
3707 static unsigned sxhash_list P_ ((Lisp_Object, int));
|
|
3708 static unsigned sxhash_vector P_ ((Lisp_Object, int));
|
|
3709 static unsigned sxhash_bool_vector P_ ((Lisp_Object));
|
27530
|
3710 static int sweep_weak_table P_ ((struct Lisp_Hash_Table *, int));
|
25005
|
3711
|
|
3712
|
|
3713
|
|
3714 /***********************************************************************
|
|
3715 Utilities
|
|
3716 ***********************************************************************/
|
|
3717
|
|
3718 /* If OBJ is a Lisp hash table, return a pointer to its struct
|
|
3719 Lisp_Hash_Table. Otherwise, signal an error. */
|
|
3720
|
|
3721 static struct Lisp_Hash_Table *
|
|
3722 check_hash_table (obj)
|
|
3723 Lisp_Object obj;
|
|
3724 {
|
40656
|
3725 CHECK_HASH_TABLE (obj);
|
25005
|
3726 return XHASH_TABLE (obj);
|
|
3727 }
|
|
3728
|
|
3729
|
|
3730 /* Value is the next integer I >= N, N >= 0 which is "almost" a prime
|
|
3731 number. */
|
|
3732
|
29979
|
3733 int
|
25005
|
3734 next_almost_prime (n)
|
|
3735 int n;
|
|
3736 {
|
|
3737 if (n % 2 == 0)
|
|
3738 n += 1;
|
|
3739 if (n % 3 == 0)
|
|
3740 n += 2;
|
|
3741 if (n % 7 == 0)
|
|
3742 n += 4;
|
|
3743 return n;
|
|
3744 }
|
|
3745
|
|
3746
|
|
3747 /* Find KEY in ARGS which has size NARGS. Don't consider indices for
|
|
3748 which USED[I] is non-zero. If found at index I in ARGS, set
|
|
3749 USED[I] and USED[I + 1] to 1, and return I + 1. Otherwise return
|
|
3750 -1. This function is used to extract a keyword/argument pair from
|
|
3751 a DEFUN parameter list. */
|
|
3752
|
|
3753 static int
|
|
3754 get_key_arg (key, nargs, args, used)
|
|
3755 Lisp_Object key;
|
|
3756 int nargs;
|
|
3757 Lisp_Object *args;
|
|
3758 char *used;
|
|
3759 {
|
|
3760 int i;
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
3761
|
25005
|
3762 for (i = 0; i < nargs - 1; ++i)
|
|
3763 if (!used[i] && EQ (args[i], key))
|
|
3764 break;
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
3765
|
25005
|
3766 if (i >= nargs - 1)
|
|
3767 i = -1;
|
|
3768 else
|
|
3769 {
|
|
3770 used[i++] = 1;
|
|
3771 used[i] = 1;
|
|
3772 }
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
3773
|
25005
|
3774 return i;
|
|
3775 }
|
|
3776
|
|
3777
|
|
3778 /* Return a Lisp vector which has the same contents as VEC but has
|
|
3779 size NEW_SIZE, NEW_SIZE >= VEC->size. Entries in the resulting
|
|
3780 vector that are not copied from VEC are set to INIT. */
|
|
3781
|
28481
|
3782 Lisp_Object
|
25005
|
3783 larger_vector (vec, new_size, init)
|
|
3784 Lisp_Object vec;
|
|
3785 int new_size;
|
|
3786 Lisp_Object init;
|
|
3787 {
|
|
3788 struct Lisp_Vector *v;
|
|
3789 int i, old_size;
|
|
3790
|
|
3791 xassert (VECTORP (vec));
|
74163
|
3792 old_size = ASIZE (vec);
|
25005
|
3793 xassert (new_size >= old_size);
|
|
3794
|
36431
|
3795 v = allocate_vector (new_size);
|
25005
|
3796 bcopy (XVECTOR (vec)->contents, v->contents,
|
|
3797 old_size * sizeof *v->contents);
|
|
3798 for (i = old_size; i < new_size; ++i)
|
|
3799 v->contents[i] = init;
|
|
3800 XSETVECTOR (vec, v);
|
|
3801 return vec;
|
|
3802 }
|
|
3803
|
|
3804
|
|
3805 /***********************************************************************
|
|
3806 Low-level Functions
|
|
3807 ***********************************************************************/
|
|
3808
|
|
3809 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
|
|
3810 HASH2 in hash table H using `eql'. Value is non-zero if KEY1 and
|
|
3811 KEY2 are the same. */
|
|
3812
|
|
3813 static int
|
|
3814 cmpfn_eql (h, key1, hash1, key2, hash2)
|
|
3815 struct Lisp_Hash_Table *h;
|
|
3816 Lisp_Object key1, key2;
|
|
3817 unsigned hash1, hash2;
|
|
3818 {
|
25349
|
3819 return (FLOATP (key1)
|
|
3820 && FLOATP (key2)
|
25495
|
3821 && XFLOAT_DATA (key1) == XFLOAT_DATA (key2));
|
25005
|
3822 }
|
|
3823
|
|
3824
|
|
3825 /* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
|
|
3826 HASH2 in hash table H using `equal'. Value is non-zero if KEY1 and
|
|
3827 KEY2 are the same. */
|
|
3828
|
|
3829 static int
|
|
3830 cmpfn_equal (h, key1, hash1, key2, hash2)
|
|
3831 struct Lisp_Hash_Table *h;
|
|
3832 Lisp_Object key1, key2;
|
|
3833 unsigned hash1, hash2;
|
|
3834 {
|
25349
|
3835 return hash1 == hash2 && !NILP (Fequal (key1, key2));
|
25005
|
3836 }
|
|
3837
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
3838
|
25005
|
3839 /* Compare KEY1 which has hash code HASH1, and KEY2 with hash code
|
|
3840 HASH2 in hash table H using H->user_cmp_function. Value is non-zero
|
|
3841 if KEY1 and KEY2 are the same. */
|
|
3842
|
|
3843 static int
|
|
3844 cmpfn_user_defined (h, key1, hash1, key2, hash2)
|
|
3845 struct Lisp_Hash_Table *h;
|
|
3846 Lisp_Object key1, key2;
|
|
3847 unsigned hash1, hash2;
|
|
3848 {
|
|
3849 if (hash1 == hash2)
|
|
3850 {
|
|
3851 Lisp_Object args[3];
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
3852
|
25005
|
3853 args[0] = h->user_cmp_function;
|
|
3854 args[1] = key1;
|
|
3855 args[2] = key2;
|
|
3856 return !NILP (Ffuncall (3, args));
|
|
3857 }
|
|
3858 else
|
|
3859 return 0;
|
|
3860 }
|
|
3861
|
|
3862
|
|
3863 /* Value is a hash code for KEY for use in hash table H which uses
|
|
3864 `eq' to compare keys. The hash code returned is guaranteed to fit
|
|
3865 in a Lisp integer. */
|
|
3866
|
|
3867 static unsigned
|
|
3868 hashfn_eq (h, key)
|
|
3869 struct Lisp_Hash_Table *h;
|
|
3870 Lisp_Object key;
|
|
3871 {
|
90970
|
3872 unsigned hash = XUINT (key) ^ XTYPE (key);
|
53090
|
3873 xassert ((hash & ~INTMASK) == 0);
|
30760
|
3874 return hash;
|
25005
|
3875 }
|
|
3876
|
|
3877
|
|
3878 /* Value is a hash code for KEY for use in hash table H which uses
|
|
3879 `eql' to compare keys. The hash code returned is guaranteed to fit
|
|
3880 in a Lisp integer. */
|
|
3881
|
|
3882 static unsigned
|
|
3883 hashfn_eql (h, key)
|
|
3884 struct Lisp_Hash_Table *h;
|
|
3885 Lisp_Object key;
|
|
3886 {
|
30760
|
3887 unsigned hash;
|
|
3888 if (FLOATP (key))
|
|
3889 hash = sxhash (key, 0);
|
25005
|
3890 else
|
90970
|
3891 hash = XUINT (key) ^ XTYPE (key);
|
53090
|
3892 xassert ((hash & ~INTMASK) == 0);
|
30760
|
3893 return hash;
|
25005
|
3894 }
|
|
3895
|
|
3896
|
|
3897 /* Value is a hash code for KEY for use in hash table H which uses
|
|
3898 `equal' to compare keys. The hash code returned is guaranteed to fit
|
|
3899 in a Lisp integer. */
|
|
3900
|
|
3901 static unsigned
|
|
3902 hashfn_equal (h, key)
|
|
3903 struct Lisp_Hash_Table *h;
|
|
3904 Lisp_Object key;
|
|
3905 {
|
30760
|
3906 unsigned hash = sxhash (key, 0);
|
53090
|
3907 xassert ((hash & ~INTMASK) == 0);
|
30760
|
3908 return hash;
|
25005
|
3909 }
|
|
3910
|
|
3911
|
|
3912 /* Value is a hash code for KEY for use in hash table H which uses as
|
|
3913 user-defined function to compare keys. The hash code returned is
|
|
3914 guaranteed to fit in a Lisp integer. */
|
|
3915
|
|
3916 static unsigned
|
|
3917 hashfn_user_defined (h, key)
|
|
3918 struct Lisp_Hash_Table *h;
|
|
3919 Lisp_Object key;
|
|
3920 {
|
|
3921 Lisp_Object args[2], hash;
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
3922
|
25005
|
3923 args[0] = h->user_hash_function;
|
|
3924 args[1] = key;
|
|
3925 hash = Ffuncall (2, args);
|
|
3926 if (!INTEGERP (hash))
|
71979
|
3927 signal_error ("Invalid hash code returned from user-supplied hash function", hash);
|
25005
|
3928 return XUINT (hash);
|
|
3929 }
|
|
3930
|
|
3931
|
|
3932 /* Create and initialize a new hash table.
|
|
3933
|
|
3934 TEST specifies the test the hash table will use to compare keys.
|
|
3935 It must be either one of the predefined tests `eq', `eql' or
|
|
3936 `equal' or a symbol denoting a user-defined test named TEST with
|
|
3937 test and hash functions USER_TEST and USER_HASH.
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
3938
|
30602
|
3939 Give the table initial capacity SIZE, SIZE >= 0, an integer.
|
25005
|
3940
|
|
3941 If REHASH_SIZE is an integer, it must be > 0, and this hash table's
|
|
3942 new size when it becomes full is computed by adding REHASH_SIZE to
|
|
3943 its old size. If REHASH_SIZE is a float, it must be > 1.0, and the
|
|
3944 table's new size is computed by multiplying its old size with
|
|
3945 REHASH_SIZE.
|
|
3946
|
|
3947 REHASH_THRESHOLD must be a float <= 1.0, and > 0. The table will
|
|
3948 be resized when the ratio of (number of entries in the table) /
|
|
3949 (table size) is >= REHASH_THRESHOLD.
|
|
3950
|
|
3951 WEAK specifies the weakness of the table. If non-nil, it must be
|
30496
|
3952 one of the symbols `key', `value', `key-or-value', or `key-and-value'. */
|
25005
|
3953
|
|
3954 Lisp_Object
|
|
3955 make_hash_table (test, size, rehash_size, rehash_threshold, weak,
|
|
3956 user_test, user_hash)
|
|
3957 Lisp_Object test, size, rehash_size, rehash_threshold, weak;
|
|
3958 Lisp_Object user_test, user_hash;
|
|
3959 {
|
|
3960 struct Lisp_Hash_Table *h;
|
|
3961 Lisp_Object table;
|
36431
|
3962 int index_size, i, sz;
|
25005
|
3963
|
|
3964 /* Preconditions. */
|
|
3965 xassert (SYMBOLP (test));
|
30602
|
3966 xassert (INTEGERP (size) && XINT (size) >= 0);
|
25005
|
3967 xassert ((INTEGERP (rehash_size) && XINT (rehash_size) > 0)
|
|
3968 || (FLOATP (rehash_size) && XFLOATINT (rehash_size) > 1.0));
|
|
3969 xassert (FLOATP (rehash_threshold)
|
|
3970 && XFLOATINT (rehash_threshold) > 0
|
|
3971 && XFLOATINT (rehash_threshold) <= 1.0);
|
|
3972
|
30602
|
3973 if (XFASTINT (size) == 0)
|
|
3974 size = make_number (1);
|
|
3975
|
36431
|
3976 /* Allocate a table and initialize it. */
|
|
3977 h = allocate_hash_table ();
|
25005
|
3978
|
|
3979 /* Initialize hash table slots. */
|
|
3980 sz = XFASTINT (size);
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
3981
|
25005
|
3982 h->test = test;
|
|
3983 if (EQ (test, Qeql))
|
|
3984 {
|
|
3985 h->cmpfn = cmpfn_eql;
|
|
3986 h->hashfn = hashfn_eql;
|
|
3987 }
|
|
3988 else if (EQ (test, Qeq))
|
|
3989 {
|
25349
|
3990 h->cmpfn = NULL;
|
25005
|
3991 h->hashfn = hashfn_eq;
|
|
3992 }
|
|
3993 else if (EQ (test, Qequal))
|
|
3994 {
|
|
3995 h->cmpfn = cmpfn_equal;
|
|
3996 h->hashfn = hashfn_equal;
|
|
3997 }
|
|
3998 else
|
|
3999 {
|
|
4000 h->user_cmp_function = user_test;
|
|
4001 h->user_hash_function = user_hash;
|
|
4002 h->cmpfn = cmpfn_user_defined;
|
|
4003 h->hashfn = hashfn_user_defined;
|
|
4004 }
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
4005
|
25005
|
4006 h->weak = weak;
|
|
4007 h->rehash_threshold = rehash_threshold;
|
|
4008 h->rehash_size = rehash_size;
|
85021
a0c901e4e649
* lisp.h (struct Lisp_Hash_Table): Move non-traced elements at the end.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
4009 h->count = 0;
|
25005
|
4010 h->key_and_value = Fmake_vector (make_number (2 * sz), Qnil);
|
|
4011 h->hash = Fmake_vector (size, Qnil);
|
|
4012 h->next = Fmake_vector (size, Qnil);
|
29809
|
4013 /* Cast to int here avoids losing with gcc 2.95 on Tru64/Alpha... */
|
|
4014 index_size = next_almost_prime ((int) (sz / XFLOATINT (rehash_threshold)));
|
25005
|
4015 h->index = Fmake_vector (make_number (index_size), Qnil);
|
|
4016
|
|
4017 /* Set up the free list. */
|
|
4018 for (i = 0; i < sz - 1; ++i)
|
|
4019 HASH_NEXT (h, i) = make_number (i + 1);
|
|
4020 h->next_free = make_number (0);
|
|
4021
|
|
4022 XSET_HASH_TABLE (table, h);
|
|
4023 xassert (HASH_TABLE_P (table));
|
|
4024 xassert (XHASH_TABLE (table) == h);
|
|
4025
|
|
4026 /* Maybe add this hash table to the list of all weak hash tables. */
|
|
4027 if (NILP (h->weak))
|
81813
32d8fd242bb2
* lisp.h (struct Lisp_Hash_Table): Turn next_weak into a bare pointer.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
4028 h->next_weak = NULL;
|
25005
|
4029 else
|
|
4030 {
|
81813
32d8fd242bb2
* lisp.h (struct Lisp_Hash_Table): Turn next_weak into a bare pointer.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
4031 h->next_weak = weak_hash_tables;
|
32d8fd242bb2
* lisp.h (struct Lisp_Hash_Table): Turn next_weak into a bare pointer.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
4032 weak_hash_tables = h;
|
25005
|
4033 }
|
|
4034
|
|
4035 return table;
|
|
4036 }
|
|
4037
|
|
4038
|
25365
|
4039 /* Return a copy of hash table H1. Keys and values are not copied,
|
|
4040 only the table itself is. */
|
|
4041
|
|
4042 Lisp_Object
|
|
4043 copy_hash_table (h1)
|
|
4044 struct Lisp_Hash_Table *h1;
|
|
4045 {
|
|
4046 Lisp_Object table;
|
|
4047 struct Lisp_Hash_Table *h2;
|
40769
|
4048 struct Lisp_Vector *next;
|
36431
|
4049
|
|
4050 h2 = allocate_hash_table ();
|
25365
|
4051 next = h2->vec_next;
|
|
4052 bcopy (h1, h2, sizeof *h2);
|
|
4053 h2->vec_next = next;
|
|
4054 h2->key_and_value = Fcopy_sequence (h1->key_and_value);
|
|
4055 h2->hash = Fcopy_sequence (h1->hash);
|
|
4056 h2->next = Fcopy_sequence (h1->next);
|
|
4057 h2->index = Fcopy_sequence (h1->index);
|
|
4058 XSET_HASH_TABLE (table, h2);
|
|
4059
|
|
4060 /* Maybe add this hash table to the list of all weak hash tables. */
|
|
4061 if (!NILP (h2->weak))
|
|
4062 {
|
81813
32d8fd242bb2
* lisp.h (struct Lisp_Hash_Table): Turn next_weak into a bare pointer.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
4063 h2->next_weak = weak_hash_tables;
|
32d8fd242bb2
* lisp.h (struct Lisp_Hash_Table): Turn next_weak into a bare pointer.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
4064 weak_hash_tables = h2;
|
25365
|
4065 }
|
|
4066
|
|
4067 return table;
|
|
4068 }
|
|
4069
|
|
4070
|
25005
|
4071 /* Resize hash table H if it's too full. If H cannot be resized
|
|
4072 because it's already too large, throw an error. */
|
|
4073
|
|
4074 static INLINE void
|
|
4075 maybe_resize_hash_table (h)
|
|
4076 struct Lisp_Hash_Table *h;
|
|
4077 {
|
|
4078 if (NILP (h->next_free))
|
|
4079 {
|
|
4080 int old_size = HASH_TABLE_SIZE (h);
|
|
4081 int i, new_size, index_size;
|
75218
6a5ce97ea40d
(maybe_resize_hash_table): Copy new size of hash table into EMACS_INT to avoid
Eli Zaretskii <eliz@gnu.org>
diff
changeset
|
4082 EMACS_INT nsize;
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
4083
|
25005
|
4084 if (INTEGERP (h->rehash_size))
|
|
4085 new_size = old_size + XFASTINT (h->rehash_size);
|
|
4086 else
|
|
4087 new_size = old_size * XFLOATINT (h->rehash_size);
|
27901
|
4088 new_size = max (old_size + 1, new_size);
|
29809
|
4089 index_size = next_almost_prime ((int)
|
|
4090 (new_size
|
|
4091 / XFLOATINT (h->rehash_threshold)));
|
75218
6a5ce97ea40d
(maybe_resize_hash_table): Copy new size of hash table into EMACS_INT to avoid
Eli Zaretskii <eliz@gnu.org>
diff
changeset
|
4092 /* Assignment to EMACS_INT stops GCC whining about limited range
|
6a5ce97ea40d
(maybe_resize_hash_table): Copy new size of hash table into EMACS_INT to avoid
Eli Zaretskii <eliz@gnu.org>
diff
changeset
|
4093 of data type. */
|
6a5ce97ea40d
(maybe_resize_hash_table): Copy new size of hash table into EMACS_INT to avoid
Eli Zaretskii <eliz@gnu.org>
diff
changeset
|
4094 nsize = max (index_size, 2 * new_size);
|
6a5ce97ea40d
(maybe_resize_hash_table): Copy new size of hash table into EMACS_INT to avoid
Eli Zaretskii <eliz@gnu.org>
diff
changeset
|
4095 if (nsize > MOST_POSITIVE_FIXNUM)
|
25005
|
4096 error ("Hash table too large to resize");
|
|
4097
|
|
4098 h->key_and_value = larger_vector (h->key_and_value, 2 * new_size, Qnil);
|
|
4099 h->next = larger_vector (h->next, new_size, Qnil);
|
|
4100 h->hash = larger_vector (h->hash, new_size, Qnil);
|
|
4101 h->index = Fmake_vector (make_number (index_size), Qnil);
|
|
4102
|
|
4103 /* Update the free list. Do it so that new entries are added at
|
|
4104 the end of the free list. This makes some operations like
|
|
4105 maphash faster. */
|
|
4106 for (i = old_size; i < new_size - 1; ++i)
|
|
4107 HASH_NEXT (h, i) = make_number (i + 1);
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
4108
|
25005
|
4109 if (!NILP (h->next_free))
|
|
4110 {
|
|
4111 Lisp_Object last, next;
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
4112
|
25005
|
4113 last = h->next_free;
|
|
4114 while (next = HASH_NEXT (h, XFASTINT (last)),
|
|
4115 !NILP (next))
|
|
4116 last = next;
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
4117
|
25005
|
4118 HASH_NEXT (h, XFASTINT (last)) = make_number (old_size);
|
|
4119 }
|
|
4120 else
|
|
4121 XSETFASTINT (h->next_free, old_size);
|
|
4122
|
|
4123 /* Rehash. */
|
|
4124 for (i = 0; i < old_size; ++i)
|
|
4125 if (!NILP (HASH_HASH (h, i)))
|
|
4126 {
|
|
4127 unsigned hash_code = XUINT (HASH_HASH (h, i));
|
74163
|
4128 int start_of_bucket = hash_code % ASIZE (h->index);
|
25005
|
4129 HASH_NEXT (h, i) = HASH_INDEX (h, start_of_bucket);
|
|
4130 HASH_INDEX (h, start_of_bucket) = make_number (i);
|
|
4131 }
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
4132 }
|
25005
|
4133 }
|
|
4134
|
|
4135
|
|
4136 /* Lookup KEY in hash table H. If HASH is non-null, return in *HASH
|
|
4137 the hash code of KEY. Value is the index of the entry in H
|
|
4138 matching KEY, or -1 if not found. */
|
|
4139
|
|
4140 int
|
|
4141 hash_lookup (h, key, hash)
|
|
4142 struct Lisp_Hash_Table *h;
|
|
4143 Lisp_Object key;
|
|
4144 unsigned *hash;
|
|
4145 {
|
|
4146 unsigned hash_code;
|
|
4147 int start_of_bucket;
|
|
4148 Lisp_Object idx;
|
|
4149
|
|
4150 hash_code = h->hashfn (h, key);
|
|
4151 if (hash)
|
|
4152 *hash = hash_code;
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
4153
|
74163
|
4154 start_of_bucket = hash_code % ASIZE (h->index);
|
25005
|
4155 idx = HASH_INDEX (h, start_of_bucket);
|
|
4156
|
28555
|
4157 /* We need not gcpro idx since it's either an integer or nil. */
|
25005
|
4158 while (!NILP (idx))
|
|
4159 {
|
|
4160 int i = XFASTINT (idx);
|
25349
|
4161 if (EQ (key, HASH_KEY (h, i))
|
|
4162 || (h->cmpfn
|
|
4163 && h->cmpfn (h, key, hash_code,
|
28507
b6f06a755c7d
make_number/XINT/XUINT conversions; EQ/== fixes; ==Qnil -> NILP
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
4164 HASH_KEY (h, i), XUINT (HASH_HASH (h, i)))))
|
25005
|
4165 break;
|
|
4166 idx = HASH_NEXT (h, i);
|
|
4167 }
|
|
4168
|
|
4169 return NILP (idx) ? -1 : XFASTINT (idx);
|
|
4170 }
|
|
4171
|
|
4172
|
|
4173 /* Put an entry into hash table H that associates KEY with VALUE.
|
26856
|
4174 HASH is a previously computed hash code of KEY.
|
|
4175 Value is the index of the entry in H matching KEY. */
|
|
4176
|
|
4177 int
|
25005
|
4178 hash_put (h, key, value, hash)
|
|
4179 struct Lisp_Hash_Table *h;
|
|
4180 Lisp_Object key, value;
|
|
4181 unsigned hash;
|
|
4182 {
|
|
4183 int start_of_bucket, i;
|
|
4184
|
53090
|
4185 xassert ((hash & ~INTMASK) == 0);
|
25005
|
4186
|
|
4187 /* Increment count after resizing because resizing may fail. */
|
|
4188 maybe_resize_hash_table (h);
|
85021
a0c901e4e649
* lisp.h (struct Lisp_Hash_Table): Move non-traced elements at the end.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
4189 h->count++;
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
4190
|
25005
|
4191 /* Store key/value in the key_and_value vector. */
|
|
4192 i = XFASTINT (h->next_free);
|
|
4193 h->next_free = HASH_NEXT (h, i);
|
|
4194 HASH_KEY (h, i) = key;
|
|
4195 HASH_VALUE (h, i) = value;
|
|
4196
|
|
4197 /* Remember its hash code. */
|
|
4198 HASH_HASH (h, i) = make_number (hash);
|
|
4199
|
|
4200 /* Add new entry to its collision chain. */
|
74163
|
4201 start_of_bucket = hash % ASIZE (h->index);
|
25005
|
4202 HASH_NEXT (h, i) = HASH_INDEX (h, start_of_bucket);
|
|
4203 HASH_INDEX (h, start_of_bucket) = make_number (i);
|
26856
|
4204 return i;
|
25005
|
4205 }
|
|
4206
|
|
4207
|
|
4208 /* Remove the entry matching KEY from hash table H, if there is one. */
|
|
4209
|
96764
|
4210 static void
|
96815
be932007d518
by renaming, get rid of need for hash_remove() redefinitions for NS platform; also, adjust nsgui dependencies in Makefile
Adrian Robert <Adrian.B.Robert@gmail.com>
diff
changeset
|
4211 hash_remove_from_table (h, key)
|
25005
|
4212 struct Lisp_Hash_Table *h;
|
|
4213 Lisp_Object key;
|
|
4214 {
|
|
4215 unsigned hash_code;
|
|
4216 int start_of_bucket;
|
|
4217 Lisp_Object idx, prev;
|
|
4218
|
|
4219 hash_code = h->hashfn (h, key);
|
74163
|
4220 start_of_bucket = hash_code % ASIZE (h->index);
|
25005
|
4221 idx = HASH_INDEX (h, start_of_bucket);
|
|
4222 prev = Qnil;
|
|
4223
|
28555
|
4224 /* We need not gcpro idx, prev since they're either integers or nil. */
|
25005
|
4225 while (!NILP (idx))
|
|
4226 {
|
|
4227 int i = XFASTINT (idx);
|
|
4228
|
25349
|
4229 if (EQ (key, HASH_KEY (h, i))
|
|
4230 || (h->cmpfn
|
|
4231 && h->cmpfn (h, key, hash_code,
|
28507
b6f06a755c7d
make_number/XINT/XUINT conversions; EQ/== fixes; ==Qnil -> NILP
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
4232 HASH_KEY (h, i), XUINT (HASH_HASH (h, i)))))
|
25005
|
4233 {
|
|
4234 /* Take entry out of collision chain. */
|
|
4235 if (NILP (prev))
|
|
4236 HASH_INDEX (h, start_of_bucket) = HASH_NEXT (h, i);
|
|
4237 else
|
|
4238 HASH_NEXT (h, XFASTINT (prev)) = HASH_NEXT (h, i);
|
|
4239
|
|
4240 /* Clear slots in key_and_value and add the slots to
|
|
4241 the free list. */
|
|
4242 HASH_KEY (h, i) = HASH_VALUE (h, i) = HASH_HASH (h, i) = Qnil;
|
|
4243 HASH_NEXT (h, i) = h->next_free;
|
|
4244 h->next_free = make_number (i);
|
85021
a0c901e4e649
* lisp.h (struct Lisp_Hash_Table): Move non-traced elements at the end.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
4245 h->count--;
|
a0c901e4e649
* lisp.h (struct Lisp_Hash_Table): Move non-traced elements at the end.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
4246 xassert (h->count >= 0);
|
25005
|
4247 break;
|
|
4248 }
|
|
4249 else
|
|
4250 {
|
|
4251 prev = idx;
|
|
4252 idx = HASH_NEXT (h, i);
|
|
4253 }
|
|
4254 }
|
|
4255 }
|
|
4256
|
|
4257
|
|
4258 /* Clear hash table H. */
|
|
4259
|
|
4260 void
|
|
4261 hash_clear (h)
|
|
4262 struct Lisp_Hash_Table *h;
|
|
4263 {
|
85021
a0c901e4e649
* lisp.h (struct Lisp_Hash_Table): Move non-traced elements at the end.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
4264 if (h->count > 0)
|
25005
|
4265 {
|
|
4266 int i, size = HASH_TABLE_SIZE (h);
|
|
4267
|
|
4268 for (i = 0; i < size; ++i)
|
|
4269 {
|
|
4270 HASH_NEXT (h, i) = i < size - 1 ? make_number (i + 1) : Qnil;
|
|
4271 HASH_KEY (h, i) = Qnil;
|
|
4272 HASH_VALUE (h, i) = Qnil;
|
|
4273 HASH_HASH (h, i) = Qnil;
|
|
4274 }
|
|
4275
|
74163
|
4276 for (i = 0; i < ASIZE (h->index); ++i)
|
91667
|
4277 ASET (h->index, i, Qnil);
|
25005
|
4278
|
|
4279 h->next_free = make_number (0);
|
85021
a0c901e4e649
* lisp.h (struct Lisp_Hash_Table): Move non-traced elements at the end.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
4280 h->count = 0;
|
25005
|
4281 }
|
|
4282 }
|
|
4283
|
|
4284
|
|
4285
|
|
4286 /************************************************************************
|
|
4287 Weak Hash Tables
|
|
4288 ************************************************************************/
|
|
4289
|
94992
|
4290 void
|
|
4291 init_weak_hash_tables ()
|
|
4292 {
|
|
4293 weak_hash_tables = NULL;
|
|
4294 }
|
|
4295
|
27530
|
4296 /* Sweep weak hash table H. REMOVE_ENTRIES_P non-zero means remove
|
|
4297 entries from the table that don't survive the current GC.
|
|
4298 REMOVE_ENTRIES_P zero means mark entries that are in use. Value is
|
|
4299 non-zero if anything was marked. */
|
|
4300
|
|
4301 static int
|
|
4302 sweep_weak_table (h, remove_entries_p)
|
|
4303 struct Lisp_Hash_Table *h;
|
|
4304 int remove_entries_p;
|
|
4305 {
|
|
4306 int bucket, n, marked;
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
4307
|
74163
|
4308 n = ASIZE (h->index) & ~ARRAY_MARK_FLAG;
|
27530
|
4309 marked = 0;
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
4310
|
27530
|
4311 for (bucket = 0; bucket < n; ++bucket)
|
|
4312 {
|
35513
|
4313 Lisp_Object idx, next, prev;
|
27530
|
4314
|
|
4315 /* Follow collision chain, removing entries that
|
|
4316 don't survive this garbage collection. */
|
|
4317 prev = Qnil;
|
90970
|
4318 for (idx = HASH_INDEX (h, bucket); !NILP (idx); idx = next)
|
27530
|
4319 {
|
|
4320 int i = XFASTINT (idx);
|
35513
|
4321 int key_known_to_survive_p = survives_gc_p (HASH_KEY (h, i));
|
|
4322 int value_known_to_survive_p = survives_gc_p (HASH_VALUE (h, i));
|
|
4323 int remove_p;
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
4324
|
27530
|
4325 if (EQ (h->weak, Qkey))
|
30007
|
4326 remove_p = !key_known_to_survive_p;
|
27530
|
4327 else if (EQ (h->weak, Qvalue))
|
30007
|
4328 remove_p = !value_known_to_survive_p;
|
30496
|
4329 else if (EQ (h->weak, Qkey_or_value))
|
30637
|
4330 remove_p = !(key_known_to_survive_p || value_known_to_survive_p);
|
30496
|
4331 else if (EQ (h->weak, Qkey_and_value))
|
30637
|
4332 remove_p = !(key_known_to_survive_p && value_known_to_survive_p);
|
27530
|
4333 else
|
|
4334 abort ();
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
4335
|
27530
|
4336 next = HASH_NEXT (h, i);
|
|
4337
|
|
4338 if (remove_entries_p)
|
|
4339 {
|
|
4340 if (remove_p)
|
|
4341 {
|
|
4342 /* Take out of collision chain. */
|
90970
|
4343 if (NILP (prev))
|
35513
|
4344 HASH_INDEX (h, bucket) = next;
|
27530
|
4345 else
|
|
4346 HASH_NEXT (h, XFASTINT (prev)) = next;
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
4347
|
27530
|
4348 /* Add to free list. */
|
|
4349 HASH_NEXT (h, i) = h->next_free;
|
|
4350 h->next_free = idx;
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
4351
|
27530
|
4352 /* Clear key, value, and hash. */
|
|
4353 HASH_KEY (h, i) = HASH_VALUE (h, i) = Qnil;
|
|
4354 HASH_HASH (h, i) = Qnil;
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
4355
|
85021
a0c901e4e649
* lisp.h (struct Lisp_Hash_Table): Move non-traced elements at the end.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
4356 h->count--;
|
27530
|
4357 }
|
59630
|
4358 else
|
|
4359 {
|
|
4360 prev = idx;
|
|
4361 }
|
27530
|
4362 }
|
|
4363 else
|
|
4364 {
|
|
4365 if (!remove_p)
|
|
4366 {
|
|
4367 /* Make sure key and value survive. */
|
30007
|
4368 if (!key_known_to_survive_p)
|
|
4369 {
|
51768
|
4370 mark_object (HASH_KEY (h, i));
|
30007
|
4371 marked = 1;
|
|
4372 }
|
|
4373
|
|
4374 if (!value_known_to_survive_p)
|
|
4375 {
|
51768
|
4376 mark_object (HASH_VALUE (h, i));
|
30007
|
4377 marked = 1;
|
|
4378 }
|
27530
|
4379 }
|
|
4380 }
|
|
4381 }
|
|
4382 }
|
|
4383
|
|
4384 return marked;
|
|
4385 }
|
|
4386
|
25005
|
4387 /* Remove elements from weak hash tables that don't survive the
|
|
4388 current garbage collection. Remove weak tables that don't survive
|
|
4389 from Vweak_hash_tables. Called from gc_sweep. */
|
|
4390
|
|
4391 void
|
|
4392 sweep_weak_hash_tables ()
|
|
4393 {
|
81813
32d8fd242bb2
* lisp.h (struct Lisp_Hash_Table): Turn next_weak into a bare pointer.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
4394 struct Lisp_Hash_Table *h, *used, *next;
|
27530
|
4395 int marked;
|
|
4396
|
|
4397 /* Mark all keys and values that are in use. Keep on marking until
|
|
4398 there is no more change. This is necessary for cases like
|
|
4399 value-weak table A containing an entry X -> Y, where Y is used in a
|
|
4400 key-weak table B, Z -> Y. If B comes after A in the list of weak
|
|
4401 tables, X -> Y might be removed from A, although when looking at B
|
|
4402 one finds that it shouldn't. */
|
|
4403 do
|
|
4404 {
|
|
4405 marked = 0;
|
81813
32d8fd242bb2
* lisp.h (struct Lisp_Hash_Table): Turn next_weak into a bare pointer.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
4406 for (h = weak_hash_tables; h; h = h->next_weak)
|
27530
|
4407 {
|
|
4408 if (h->size & ARRAY_MARK_FLAG)
|
|
4409 marked |= sweep_weak_table (h, 0);
|
|
4410 }
|
|
4411 }
|
|
4412 while (marked);
|
|
4413
|
|
4414 /* Remove tables and entries that aren't used. */
|
81813
32d8fd242bb2
* lisp.h (struct Lisp_Hash_Table): Turn next_weak into a bare pointer.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
4415 for (h = weak_hash_tables, used = NULL; h; h = next)
|
25005
|
4416 {
|
30634
|
4417 next = h->next_weak;
|
49246
|
4418
|
25005
|
4419 if (h->size & ARRAY_MARK_FLAG)
|
|
4420 {
|
30634
|
4421 /* TABLE is marked as used. Sweep its contents. */
|
85021
a0c901e4e649
* lisp.h (struct Lisp_Hash_Table): Move non-traced elements at the end.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
4422 if (h->count > 0)
|
27530
|
4423 sweep_weak_table (h, 1);
|
30634
|
4424
|
|
4425 /* Add table to the list of used weak hash tables. */
|
|
4426 h->next_weak = used;
|
81813
32d8fd242bb2
* lisp.h (struct Lisp_Hash_Table): Turn next_weak into a bare pointer.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
4427 used = h;
|
25005
|
4428 }
|
|
4429 }
|
30634
|
4430
|
81813
32d8fd242bb2
* lisp.h (struct Lisp_Hash_Table): Turn next_weak into a bare pointer.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
4431 weak_hash_tables = used;
|
25005
|
4432 }
|
|
4433
|
|
4434
|
|
4435
|
|
4436 /***********************************************************************
|
|
4437 Hash Code Computation
|
|
4438 ***********************************************************************/
|
|
4439
|
|
4440 /* Maximum depth up to which to dive into Lisp structures. */
|
|
4441
|
|
4442 #define SXHASH_MAX_DEPTH 3
|
|
4443
|
|
4444 /* Maximum length up to which to take list and vector elements into
|
|
4445 account. */
|
|
4446
|
|
4447 #define SXHASH_MAX_LEN 7
|
|
4448
|
|
4449 /* Combine two integers X and Y for hashing. */
|
|
4450
|
|
4451 #define SXHASH_COMBINE(X, Y) \
|
25709
|
4452 ((((unsigned)(X) << 4) + (((unsigned)(X) >> 24) & 0x0fffffff)) \
|
25005
|
4453 + (unsigned)(Y))
|
|
4454
|
|
4455
|
30760
|
4456 /* Return a hash for string PTR which has length LEN. The hash
|
|
4457 code returned is guaranteed to fit in a Lisp integer. */
|
25005
|
4458
|
|
4459 static unsigned
|
|
4460 sxhash_string (ptr, len)
|
|
4461 unsigned char *ptr;
|
|
4462 int len;
|
|
4463 {
|
|
4464 unsigned char *p = ptr;
|
|
4465 unsigned char *end = p + len;
|
|
4466 unsigned char c;
|
|
4467 unsigned hash = 0;
|
|
4468
|
|
4469 while (p != end)
|
|
4470 {
|
|
4471 c = *p++;
|
|
4472 if (c >= 0140)
|
|
4473 c -= 40;
|
72511
|
4474 hash = ((hash << 4) + (hash >> 28) + c);
|
25005
|
4475 }
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
4476
|
53090
|
4477 return hash & INTMASK;
|
25005
|
4478 }
|
|
4479
|
|
4480
|
|
4481 /* Return a hash for list LIST. DEPTH is the current depth in the
|
|
4482 list. We don't recurse deeper than SXHASH_MAX_DEPTH in it. */
|
|
4483
|
|
4484 static unsigned
|
|
4485 sxhash_list (list, depth)
|
|
4486 Lisp_Object list;
|
|
4487 int depth;
|
|
4488 {
|
|
4489 unsigned hash = 0;
|
|
4490 int i;
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
4491
|
25005
|
4492 if (depth < SXHASH_MAX_DEPTH)
|
|
4493 for (i = 0;
|
|
4494 CONSP (list) && i < SXHASH_MAX_LEN;
|
|
4495 list = XCDR (list), ++i)
|
|
4496 {
|
|
4497 unsigned hash2 = sxhash (XCAR (list), depth + 1);
|
|
4498 hash = SXHASH_COMBINE (hash, hash2);
|
|
4499 }
|
|
4500
|
69655
|
4501 if (!NILP (list))
|
|
4502 {
|
|
4503 unsigned hash2 = sxhash (list, depth + 1);
|
|
4504 hash = SXHASH_COMBINE (hash, hash2);
|
|
4505 }
|
|
4506
|
25005
|
4507 return hash;
|
|
4508 }
|
|
4509
|
|
4510
|
|
4511 /* Return a hash for vector VECTOR. DEPTH is the current depth in
|
|
4512 the Lisp structure. */
|
|
4513
|
|
4514 static unsigned
|
|
4515 sxhash_vector (vec, depth)
|
|
4516 Lisp_Object vec;
|
|
4517 int depth;
|
|
4518 {
|
74163
|
4519 unsigned hash = ASIZE (vec);
|
25005
|
4520 int i, n;
|
|
4521
|
74163
|
4522 n = min (SXHASH_MAX_LEN, ASIZE (vec));
|
25005
|
4523 for (i = 0; i < n; ++i)
|
|
4524 {
|
74163
|
4525 unsigned hash2 = sxhash (AREF (vec, i), depth + 1);
|
25005
|
4526 hash = SXHASH_COMBINE (hash, hash2);
|
|
4527 }
|
|
4528
|
|
4529 return hash;
|
|
4530 }
|
|
4531
|
|
4532
|
|
4533 /* Return a hash for bool-vector VECTOR. */
|
|
4534
|
|
4535 static unsigned
|
|
4536 sxhash_bool_vector (vec)
|
|
4537 Lisp_Object vec;
|
|
4538 {
|
|
4539 unsigned hash = XBOOL_VECTOR (vec)->size;
|
|
4540 int i, n;
|
|
4541
|
|
4542 n = min (SXHASH_MAX_LEN, XBOOL_VECTOR (vec)->vector_size);
|
|
4543 for (i = 0; i < n; ++i)
|
|
4544 hash = SXHASH_COMBINE (hash, XBOOL_VECTOR (vec)->data[i]);
|
|
4545
|
|
4546 return hash;
|
|
4547 }
|
|
4548
|
|
4549
|
|
4550 /* Return a hash code for OBJ. DEPTH is the current depth in the Lisp
|
53090
|
4551 structure. Value is an unsigned integer clipped to INTMASK. */
|
25005
|
4552
|
|
4553 unsigned
|
|
4554 sxhash (obj, depth)
|
|
4555 Lisp_Object obj;
|
|
4556 int depth;
|
|
4557 {
|
|
4558 unsigned hash;
|
|
4559
|
|
4560 if (depth > SXHASH_MAX_DEPTH)
|
|
4561 return 0;
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
4562
|
25005
|
4563 switch (XTYPE (obj))
|
|
4564 {
|
|
4565 case Lisp_Int:
|
|
4566 hash = XUINT (obj);
|
|
4567 break;
|
|
4568
|
|
4569 case Lisp_Misc:
|
|
4570 hash = XUINT (obj);
|
|
4571 break;
|
|
4572
|
57988
|
4573 case Lisp_Symbol:
|
|
4574 obj = SYMBOL_NAME (obj);
|
|
4575 /* Fall through. */
|
|
4576
|
25005
|
4577 case Lisp_String:
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
4578 hash = sxhash_string (SDATA (obj), SCHARS (obj));
|
25005
|
4579 break;
|
|
4580
|
|
4581 /* This can be everything from a vector to an overlay. */
|
|
4582 case Lisp_Vectorlike:
|
|
4583 if (VECTORP (obj))
|
|
4584 /* According to the CL HyperSpec, two arrays are equal only if
|
|
4585 they are `eq', except for strings and bit-vectors. In
|
|
4586 Emacs, this works differently. We have to compare element
|
|
4587 by element. */
|
|
4588 hash = sxhash_vector (obj, depth);
|
|
4589 else if (BOOL_VECTOR_P (obj))
|
|
4590 hash = sxhash_bool_vector (obj);
|
|
4591 else
|
|
4592 /* Others are `equal' if they are `eq', so let's take their
|
|
4593 address as hash. */
|
|
4594 hash = XUINT (obj);
|
|
4595 break;
|
|
4596
|
|
4597 case Lisp_Cons:
|
|
4598 hash = sxhash_list (obj, depth);
|
|
4599 break;
|
|
4600
|
|
4601 case Lisp_Float:
|
|
4602 {
|
25495
|
4603 unsigned char *p = (unsigned char *) &XFLOAT_DATA (obj);
|
|
4604 unsigned char *e = p + sizeof XFLOAT_DATA (obj);
|
25005
|
4605 for (hash = 0; p < e; ++p)
|
|
4606 hash = SXHASH_COMBINE (hash, *p);
|
|
4607 break;
|
|
4608 }
|
|
4609
|
|
4610 default:
|
|
4611 abort ();
|
|
4612 }
|
|
4613
|
53090
|
4614 return hash & INTMASK;
|
25005
|
4615 }
|
|
4616
|
|
4617
|
|
4618
|
|
4619 /***********************************************************************
|
|
4620 Lisp Interface
|
|
4621 ***********************************************************************/
|
|
4622
|
|
4623
|
|
4624 DEFUN ("sxhash", Fsxhash, Ssxhash, 1, 1, 0,
|
39977
|
4625 doc: /* Compute a hash code for OBJ and return it as integer. */)
|
|
4626 (obj)
|
25005
|
4627 Lisp_Object obj;
|
|
4628 {
|
77908
|
4629 unsigned hash = sxhash (obj, 0);
|
25005
|
4630 return make_number (hash);
|
|
4631 }
|
|
4632
|
|
4633
|
|
4634 DEFUN ("make-hash-table", Fmake_hash_table, Smake_hash_table, 0, MANY, 0,
|
39977
|
4635 doc: /* Create and return a new hash table.
|
49246
|
4636
|
39899
|
4637 Arguments are specified as keyword/argument pairs. The following
|
|
4638 arguments are defined:
|
|
4639
|
|
4640 :test TEST -- TEST must be a symbol that specifies how to compare
|
|
4641 keys. Default is `eql'. Predefined are the tests `eq', `eql', and
|
|
4642 `equal'. User-supplied test and hash functions can be specified via
|
|
4643 `define-hash-table-test'.
|
|
4644
|
|
4645 :size SIZE -- A hint as to how many elements will be put in the table.
|
|
4646 Default is 65.
|
|
4647
|
|
4648 :rehash-size REHASH-SIZE - Indicates how to expand the table when it
|
|
4649 fills up. If REHASH-SIZE is an integer, add that many space. If it
|
|
4650 is a float, it must be > 1.0, and the new size is computed by
|
|
4651 multiplying the old size with that factor. Default is 1.5.
|
|
4652
|
|
4653 :rehash-threshold THRESHOLD -- THRESHOLD must a float > 0, and <= 1.0.
|
|
4654 Resize the hash table when ratio of the number of entries in the
|
|
4655 table. Default is 0.8.
|
|
4656
|
|
4657 :weakness WEAK -- WEAK must be one of nil, t, `key', `value',
|
|
4658 `key-or-value', or `key-and-value'. If WEAK is not nil, the table
|
|
4659 returned is a weak table. Key/value pairs are removed from a weak
|
|
4660 hash table when there are no non-weak references pointing to their
|
|
4661 key, value, one of key or value, or both key and value, depending on
|
|
4662 WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK
|
40132
75fe73bea452
(Fappend, Fconcat, Fvconcat, Fnconc, Fwidget_apply, Fmake_hash_table):
Miles Bader <miles@gnu.org>
diff
changeset
|
4663 is nil.
|
75fe73bea452
(Fappend, Fconcat, Fvconcat, Fnconc, Fwidget_apply, Fmake_hash_table):
Miles Bader <miles@gnu.org>
diff
changeset
|
4664
|
75fe73bea452
(Fappend, Fconcat, Fvconcat, Fnconc, Fwidget_apply, Fmake_hash_table):
Miles Bader <miles@gnu.org>
diff
changeset
|
4665 usage: (make-hash-table &rest KEYWORD-ARGS) */)
|
39977
|
4666 (nargs, args)
|
25005
|
4667 int nargs;
|
|
4668 Lisp_Object *args;
|
|
4669 {
|
|
4670 Lisp_Object test, size, rehash_size, rehash_threshold, weak;
|
|
4671 Lisp_Object user_test, user_hash;
|
|
4672 char *used;
|
|
4673 int i;
|
|
4674
|
|
4675 /* The vector `used' is used to keep track of arguments that
|
|
4676 have been consumed. */
|
|
4677 used = (char *) alloca (nargs * sizeof *used);
|
|
4678 bzero (used, nargs * sizeof *used);
|
|
4679
|
|
4680 /* See if there's a `:test TEST' among the arguments. */
|
|
4681 i = get_key_arg (QCtest, nargs, args, used);
|
|
4682 test = i < 0 ? Qeql : args[i];
|
|
4683 if (!EQ (test, Qeq) && !EQ (test, Qeql) && !EQ (test, Qequal))
|
|
4684 {
|
|
4685 /* See if it is a user-defined test. */
|
|
4686 Lisp_Object prop;
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
4687
|
25005
|
4688 prop = Fget (test, Qhash_table_test);
|
40734
|
4689 if (!CONSP (prop) || !CONSP (XCDR (prop)))
|
71979
|
4690 signal_error ("Invalid hash table test", test);
|
40734
|
4691 user_test = XCAR (prop);
|
|
4692 user_hash = XCAR (XCDR (prop));
|
25005
|
4693 }
|
|
4694 else
|
|
4695 user_test = user_hash = Qnil;
|
|
4696
|
|
4697 /* See if there's a `:size SIZE' argument. */
|
|
4698 i = get_key_arg (QCsize, nargs, args, used);
|
46221
|
4699 size = i < 0 ? Qnil : args[i];
|
|
4700 if (NILP (size))
|
|
4701 size = make_number (DEFAULT_HASH_SIZE);
|
|
4702 else if (!INTEGERP (size) || XINT (size) < 0)
|
71979
|
4703 signal_error ("Invalid hash table size", size);
|
25005
|
4704
|
|
4705 /* Look for `:rehash-size SIZE'. */
|
|
4706 i = get_key_arg (QCrehash_size, nargs, args, used);
|
|
4707 rehash_size = i < 0 ? make_float (DEFAULT_REHASH_SIZE) : args[i];
|
|
4708 if (!NUMBERP (rehash_size)
|
|
4709 || (INTEGERP (rehash_size) && XINT (rehash_size) <= 0)
|
|
4710 || XFLOATINT (rehash_size) <= 1.0)
|
71979
|
4711 signal_error ("Invalid hash table rehash size", rehash_size);
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
4712
|
25005
|
4713 /* Look for `:rehash-threshold THRESHOLD'. */
|
|
4714 i = get_key_arg (QCrehash_threshold, nargs, args, used);
|
|
4715 rehash_threshold = i < 0 ? make_float (DEFAULT_REHASH_THRESHOLD) : args[i];
|
|
4716 if (!FLOATP (rehash_threshold)
|
|
4717 || XFLOATINT (rehash_threshold) <= 0.0
|
|
4718 || XFLOATINT (rehash_threshold) > 1.0)
|
71979
|
4719 signal_error ("Invalid hash table rehash threshold", rehash_threshold);
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
4720
|
25455
|
4721 /* Look for `:weakness WEAK'. */
|
|
4722 i = get_key_arg (QCweakness, nargs, args, used);
|
25005
|
4723 weak = i < 0 ? Qnil : args[i];
|
30496
|
4724 if (EQ (weak, Qt))
|
|
4725 weak = Qkey_and_value;
|
25005
|
4726 if (!NILP (weak)
|
25365
|
4727 && !EQ (weak, Qkey)
|
30496
|
4728 && !EQ (weak, Qvalue)
|
|
4729 && !EQ (weak, Qkey_or_value)
|
|
4730 && !EQ (weak, Qkey_and_value))
|
71979
|
4731 signal_error ("Invalid hash table weakness", weak);
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
4732
|
25005
|
4733 /* Now, all args should have been used up, or there's a problem. */
|
|
4734 for (i = 0; i < nargs; ++i)
|
|
4735 if (!used[i])
|
71979
|
4736 signal_error ("Invalid argument list", args[i]);
|
25005
|
4737
|
|
4738 return make_hash_table (test, size, rehash_size, rehash_threshold, weak,
|
|
4739 user_test, user_hash);
|
|
4740 }
|
|
4741
|
|
4742
|
25365
|
4743 DEFUN ("copy-hash-table", Fcopy_hash_table, Scopy_hash_table, 1, 1, 0,
|
39977
|
4744 doc: /* Return a copy of hash table TABLE. */)
|
|
4745 (table)
|
25365
|
4746 Lisp_Object table;
|
|
4747 {
|
|
4748 return copy_hash_table (check_hash_table (table));
|
|
4749 }
|
|
4750
|
|
4751
|
25005
|
4752 DEFUN ("hash-table-count", Fhash_table_count, Shash_table_count, 1, 1, 0,
|
39977
|
4753 doc: /* Return the number of elements in TABLE. */)
|
|
4754 (table)
|
39899
|
4755 Lisp_Object table;
|
25005
|
4756 {
|
85021
a0c901e4e649
* lisp.h (struct Lisp_Hash_Table): Move non-traced elements at the end.
Stefan Monnier <monnier@iro.umontreal.ca>
diff
changeset
|
4757 return make_number (check_hash_table (table)->count);
|
25005
|
4758 }
|
|
4759
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
4760
|
25005
|
4761 DEFUN ("hash-table-rehash-size", Fhash_table_rehash_size,
|
|
4762 Shash_table_rehash_size, 1, 1, 0,
|
39977
|
4763 doc: /* Return the current rehash size of TABLE. */)
|
|
4764 (table)
|
39899
|
4765 Lisp_Object table;
|
25005
|
4766 {
|
|
4767 return check_hash_table (table)->rehash_size;
|
|
4768 }
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
4769
|
25005
|
4770
|
|
4771 DEFUN ("hash-table-rehash-threshold", Fhash_table_rehash_threshold,
|
|
4772 Shash_table_rehash_threshold, 1, 1, 0,
|
39977
|
4773 doc: /* Return the current rehash threshold of TABLE. */)
|
|
4774 (table)
|
39899
|
4775 Lisp_Object table;
|
25005
|
4776 {
|
|
4777 return check_hash_table (table)->rehash_threshold;
|
|
4778 }
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
4779
|
25005
|
4780
|
|
4781 DEFUN ("hash-table-size", Fhash_table_size, Shash_table_size, 1, 1, 0,
|
39977
|
4782 doc: /* Return the size of TABLE.
|
39899
|
4783 The size can be used as an argument to `make-hash-table' to create
|
|
4784 a hash table than can hold as many elements of TABLE holds
|
39977
|
4785 without need for resizing. */)
|
|
4786 (table)
|
25005
|
4787 Lisp_Object table;
|
|
4788 {
|
|
4789 struct Lisp_Hash_Table *h = check_hash_table (table);
|
|
4790 return make_number (HASH_TABLE_SIZE (h));
|
|
4791 }
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
4792
|
25005
|
4793
|
|
4794 DEFUN ("hash-table-test", Fhash_table_test, Shash_table_test, 1, 1, 0,
|
39977
|
4795 doc: /* Return the test TABLE uses. */)
|
|
4796 (table)
|
39899
|
4797 Lisp_Object table;
|
25005
|
4798 {
|
|
4799 return check_hash_table (table)->test;
|
|
4800 }
|
|
4801
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
4802
|
25495
|
4803 DEFUN ("hash-table-weakness", Fhash_table_weakness, Shash_table_weakness,
|
|
4804 1, 1, 0,
|
39977
|
4805 doc: /* Return the weakness of TABLE. */)
|
|
4806 (table)
|
39899
|
4807 Lisp_Object table;
|
25005
|
4808 {
|
|
4809 return check_hash_table (table)->weak;
|
|
4810 }
|
|
4811
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
4812
|
25005
|
4813 DEFUN ("hash-table-p", Fhash_table_p, Shash_table_p, 1, 1, 0,
|
39977
|
4814 doc: /* Return t if OBJ is a Lisp hash table object. */)
|
|
4815 (obj)
|
25005
|
4816 Lisp_Object obj;
|
|
4817 {
|
|
4818 return HASH_TABLE_P (obj) ? Qt : Qnil;
|
|
4819 }
|
|
4820
|
|
4821
|
|
4822 DEFUN ("clrhash", Fclrhash, Sclrhash, 1, 1, 0,
|
87961
|
4823 doc: /* Clear hash table TABLE and return it. */)
|
39977
|
4824 (table)
|
25005
|
4825 Lisp_Object table;
|
|
4826 {
|
|
4827 hash_clear (check_hash_table (table));
|
87961
|
4828 /* Be compatible with XEmacs. */
|
|
4829 return table;
|
25005
|
4830 }
|
|
4831
|
|
4832
|
|
4833 DEFUN ("gethash", Fgethash, Sgethash, 2, 3, 0,
|
39977
|
4834 doc: /* Look up KEY in TABLE and return its associated value.
|
|
4835 If KEY is not found, return DFLT which defaults to nil. */)
|
|
4836 (key, table, dflt)
|
26088
b7aa6ac26872
Add support for large files, 64-bit Solaris, system locale codings.
Paul Eggert <eggert@twinsun.com>
diff
changeset
|
4837 Lisp_Object key, table, dflt;
|
25005
|
4838 {
|
|
4839 struct Lisp_Hash_Table *h = check_hash_table (table);
|
|
4840 int i = hash_lookup (h, key, NULL);
|
|
4841 return i >= 0 ? HASH_VALUE (h, i) : dflt;
|
|
4842 }
|
|
4843
|
|
4844
|
|
4845 DEFUN ("puthash", Fputhash, Sputhash, 3, 3, 0,
|
39977
|
4846 doc: /* Associate KEY with VALUE in hash table TABLE.
|
39899
|
4847 If KEY is already present in table, replace its current value with
|
39977
|
4848 VALUE. */)
|
|
4849 (key, value, table)
|
25080
|
4850 Lisp_Object key, value, table;
|
25005
|
4851 {
|
|
4852 struct Lisp_Hash_Table *h = check_hash_table (table);
|
|
4853 int i;
|
|
4854 unsigned hash;
|
|
4855
|
|
4856 i = hash_lookup (h, key, &hash);
|
|
4857 if (i >= 0)
|
|
4858 HASH_VALUE (h, i) = value;
|
|
4859 else
|
|
4860 hash_put (h, key, value, hash);
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
4861
|
29991
|
4862 return value;
|
25005
|
4863 }
|
|
4864
|
|
4865
|
|
4866 DEFUN ("remhash", Fremhash, Sremhash, 2, 2, 0,
|
39977
|
4867 doc: /* Remove KEY from TABLE. */)
|
|
4868 (key, table)
|
25080
|
4869 Lisp_Object key, table;
|
25005
|
4870 {
|
|
4871 struct Lisp_Hash_Table *h = check_hash_table (table);
|
96815
be932007d518
by renaming, get rid of need for hash_remove() redefinitions for NS platform; also, adjust nsgui dependencies in Makefile
Adrian Robert <Adrian.B.Robert@gmail.com>
diff
changeset
|
4872 hash_remove_from_table (h, key);
|
25005
|
4873 return Qnil;
|
|
4874 }
|
|
4875
|
|
4876
|
|
4877 DEFUN ("maphash", Fmaphash, Smaphash, 2, 2, 0,
|
39977
|
4878 doc: /* Call FUNCTION for all entries in hash table TABLE.
|
63173
|
4879 FUNCTION is called with two arguments, KEY and VALUE. */)
|
39977
|
4880 (function, table)
|
25005
|
4881 Lisp_Object function, table;
|
|
4882 {
|
|
4883 struct Lisp_Hash_Table *h = check_hash_table (table);
|
|
4884 Lisp_Object args[3];
|
|
4885 int i;
|
|
4886
|
|
4887 for (i = 0; i < HASH_TABLE_SIZE (h); ++i)
|
|
4888 if (!NILP (HASH_HASH (h, i)))
|
|
4889 {
|
|
4890 args[0] = function;
|
|
4891 args[1] = HASH_KEY (h, i);
|
|
4892 args[2] = HASH_VALUE (h, i);
|
|
4893 Ffuncall (3, args);
|
|
4894 }
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
4895
|
25005
|
4896 return Qnil;
|
|
4897 }
|
|
4898
|
|
4899
|
|
4900 DEFUN ("define-hash-table-test", Fdefine_hash_table_test,
|
|
4901 Sdefine_hash_table_test, 3, 3, 0,
|
39977
|
4902 doc: /* Define a new hash table test with name NAME, a symbol.
|
49246
|
4903
|
39899
|
4904 In hash tables created with NAME specified as test, use TEST to
|
|
4905 compare keys, and HASH for computing hash codes of keys.
|
|
4906
|
|
4907 TEST must be a function taking two arguments and returning non-nil if
|
|
4908 both arguments are the same. HASH must be a function taking one
|
|
4909 argument and return an integer that is the hash code of the argument.
|
|
4910 Hash code computation should use the whole value range of integers,
|
39977
|
4911 including negative integers. */)
|
|
4912 (name, test, hash)
|
25005
|
4913 Lisp_Object name, test, hash;
|
|
4914 {
|
|
4915 return Fput (name, Qhash_table_test, list2 (test, hash));
|
|
4916 }
|
|
4917
|
28965
|
4918
|
34050
|
4919
|
34106
|
4920 /************************************************************************
|
|
4921 MD5
|
|
4922 ************************************************************************/
|
|
4923
|
34050
|
4924 #include "md5.h"
|
|
4925
|
|
4926 DEFUN ("md5", Fmd5, Smd5, 1, 5, 0,
|
39977
|
4927 doc: /* Return MD5 message digest of OBJECT, a buffer or string.
|
49246
|
4928
|
39899
|
4929 A message digest is a cryptographic checksum of a document, and the
|
|
4930 algorithm to calculate it is defined in RFC 1321.
|
|
4931
|
|
4932 The two optional arguments START and END are character positions
|
|
4933 specifying for which part of OBJECT the message digest should be
|
|
4934 computed. If nil or omitted, the digest is computed for the whole
|
|
4935 OBJECT.
|
|
4936
|
|
4937 The MD5 message digest is computed from the result of encoding the
|
|
4938 text in a coding system, not directly from the internal Emacs form of
|
|
4939 the text. The optional fourth argument CODING-SYSTEM specifies which
|
|
4940 coding system to encode the text with. It should be the same coding
|
|
4941 system that you used or will use when actually writing the text into a
|
|
4942 file.
|
|
4943
|
|
4944 If CODING-SYSTEM is nil or omitted, the default depends on OBJECT. If
|
|
4945 OBJECT is a buffer, the default for CODING-SYSTEM is whatever coding
|
|
4946 system would be chosen by default for writing this text into a file.
|
|
4947
|
|
4948 If OBJECT is a string, the most preferred coding system (see the
|
|
4949 command `prefer-coding-system') is used.
|
|
4950
|
|
4951 If NOERROR is non-nil, silently assume the `raw-text' coding if the
|
39977
|
4952 guesswork fails. Normally, an error is signaled in such case. */)
|
|
4953 (object, start, end, coding_system, noerror)
|
34050
|
4954 Lisp_Object object, start, end, coding_system, noerror;
|
|
4955 {
|
|
4956 unsigned char digest[16];
|
|
4957 unsigned char value[33];
|
|
4958 int i;
|
|
4959 int size;
|
|
4960 int size_byte = 0;
|
|
4961 int start_char = 0, end_char = 0;
|
|
4962 int start_byte = 0, end_byte = 0;
|
|
4963 register int b, e;
|
|
4964 register struct buffer *bp;
|
|
4965 int temp;
|
|
4966
|
34106
|
4967 if (STRINGP (object))
|
34050
|
4968 {
|
|
4969 if (NILP (coding_system))
|
|
4970 {
|
34106
|
4971 /* Decide the coding-system to encode the data with. */
|
|
4972
|
34050
|
4973 if (STRING_MULTIBYTE (object))
|
34106
|
4974 /* use default, we can't guess correct value */
|
88375
|
4975 coding_system = preferred_coding_system ();
|
49246
|
4976 else
|
34106
|
4977 coding_system = Qraw_text;
|
|
4978 }
|
49246
|
4979
|
34106
|
4980 if (NILP (Fcoding_system_p (coding_system)))
|
|
4981 {
|
|
4982 /* Invalid coding system. */
|
49246
|
4983
|
34106
|
4984 if (!NILP (noerror))
|
|
4985 coding_system = Qraw_text;
|
34050
|
4986 else
|
71979
|
4987 xsignal1 (Qcoding_system_error, coding_system);
|
34050
|
4988 }
|
34106
|
4989
|
|
4990 if (STRING_MULTIBYTE (object))
|
88375
|
4991 object = code_convert_string (object, coding_system, Qnil, 1, 0, 1);
|
34050
|
4992
|
46370
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
4993 size = SCHARS (object);
|
40db0673e6f0
Most uses of XSTRING combined with STRING_BYTES or indirection changed to
Ken Raeburn <raeburn@raeburn.org>
diff
changeset
|
4994 size_byte = SBYTES (object);
|
34050
|
4995
|
|
4996 if (!NILP (start))
|
|
4997 {
|
40656
|
4998 CHECK_NUMBER (start);
|
34050
|
4999
|
|
5000 start_char = XINT (start);
|
|
5001
|
|
5002 if (start_char < 0)
|
|
5003 start_char += size;
|
|
5004
|
|
5005 start_byte = string_char_to_byte (object, start_char);
|
|
5006 }
|
|
5007
|
|
5008 if (NILP (end))
|
|
5009 {
|
|
5010 end_char = size;
|
|
5011 end_byte = size_byte;
|
|
5012 }
|
|
5013 else
|
|
5014 {
|
40656
|
5015 CHECK_NUMBER (end);
|
49246
|
5016
|
34050
|
5017 end_char = XINT (end);
|
|
5018
|
|
5019 if (end_char < 0)
|
|
5020 end_char += size;
|
49246
|
5021
|
34050
|
5022 end_byte = string_char_to_byte (object, end_char);
|
|
5023 }
|
49246
|
5024
|
34050
|
5025 if (!(0 <= start_char && start_char <= end_char && end_char <= size))
|
|
5026 args_out_of_range_3 (object, make_number (start_char),
|
|
5027 make_number (end_char));
|
|
5028 }
|
|
5029 else
|
|
5030 {
|
53681
|
5031 struct buffer *prev = current_buffer;
|
|
5032
|
|
5033 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
|
|
5034
|
40656
|
5035 CHECK_BUFFER (object);
|
34050
|
5036
|
|
5037 bp = XBUFFER (object);
|
53681
|
5038 if (bp != current_buffer)
|
|
5039 set_buffer_internal (bp);
|
49246
|
5040
|
34050
|
5041 if (NILP (start))
|
53681
|
5042 b = BEGV;
|
34050
|
5043 else
|
|
5044 {
|
40656
|
5045 CHECK_NUMBER_COERCE_MARKER (start);
|
34050
|
5046 b = XINT (start);
|
|
5047 }
|
|
5048
|
|
5049 if (NILP (end))
|
53681
|
5050 e = ZV;
|
34050
|
5051 else
|
|
5052 {
|
40656
|
5053 CHECK_NUMBER_COERCE_MARKER (end);
|
34050
|
5054 e = XINT (end);
|
|
5055 }
|
49246
|
5056
|
34050
|
5057 if (b > e)
|
|
5058 temp = b, b = e, e = temp;
|
49246
|
5059
|
53681
|
5060 if (!(BEGV <= b && e <= ZV))
|
34050
|
5061 args_out_of_range (start, end);
|
49246
|
5062
|
34050
|
5063 if (NILP (coding_system))
|
|
5064 {
|
49246
|
5065 /* Decide the coding-system to encode the data with.
|
34106
|
5066 See fileio.c:Fwrite-region */
|
|
5067
|
|
5068 if (!NILP (Vcoding_system_for_write))
|
|
5069 coding_system = Vcoding_system_for_write;
|
|
5070 else
|
34050
|
5071 {
|
34106
|
5072 int force_raw_text = 0;
|
|
5073
|
|
5074 coding_system = XBUFFER (object)->buffer_file_coding_system;
|
|
5075 if (NILP (coding_system)
|
|
5076 || NILP (Flocal_variable_p (Qbuffer_file_coding_system, Qnil)))
|
|
5077 {
|
|
5078 coding_system = Qnil;
|
|
5079 if (NILP (current_buffer->enable_multibyte_characters))
|
|
5080 force_raw_text = 1;
|
|
5081 }
|
|
5082
|
|
5083 if (NILP (coding_system) && !NILP (Fbuffer_file_name(object)))
|
|
5084 {
|
|
5085 /* Check file-coding-system-alist. */
|
|
5086 Lisp_Object args[4], val;
|
49246
|
5087
|
34106
|
5088 args[0] = Qwrite_region; args[1] = start; args[2] = end;
|
|
5089 args[3] = Fbuffer_file_name(object);
|
|
5090 val = Ffind_operation_coding_system (4, args);
|
|
5091 if (CONSP (val) && !NILP (XCDR (val)))
|
|
5092 coding_system = XCDR (val);
|
|
5093 }
|
|
5094
|
|
5095 if (NILP (coding_system)
|
|
5096 && !NILP (XBUFFER (object)->buffer_file_coding_system))
|
|
5097 {
|
|
5098 /* If we still have not decided a coding system, use the
|
|
5099 default value of buffer-file-coding-system. */
|
|
5100 coding_system = XBUFFER (object)->buffer_file_coding_system;
|
|
5101 }
|
|
5102
|
|
5103 if (!force_raw_text
|
|
5104 && !NILP (Ffboundp (Vselect_safe_coding_system_function)))
|
|
5105 /* Confirm that VAL can surely encode the current region. */
|
45629
|
5106 coding_system = call4 (Vselect_safe_coding_system_function,
|
34153
|
5107 make_number (b), make_number (e),
|
45629
|
5108 coding_system, Qnil);
|
34106
|
5109
|
|
5110 if (force_raw_text)
|
|
5111 coding_system = Qraw_text;
|
|
5112 }
|
|
5113
|
|
5114 if (NILP (Fcoding_system_p (coding_system)))
|
|
5115 {
|
|
5116 /* Invalid coding system. */
|
|
5117
|
|
5118 if (!NILP (noerror))
|
|
5119 coding_system = Qraw_text;
|
|
5120 else
|
71979
|
5121 xsignal1 (Qcoding_system_error, coding_system);
|
34050
|
5122 }
|
|
5123 }
|
|
5124
|
|
5125 object = make_buffer_string (b, e, 0);
|
53681
|
5126 if (prev != current_buffer)
|
|
5127 set_buffer_internal (prev);
|
|
5128 /* Discard the unwind protect for recovering the current
|
|
5129 buffer. */
|
|
5130 specpdl_ptr--;
|
34050
|
5131
|
|
5132 if (STRING_MULTIBYTE (object))
|
89483
|
5133 object = code_convert_string (object, coding_system, Qnil, 1, 0, 0);
|
34050
|
5134 }
|
|
5135
|
49246
|
5136 md5_buffer (SDATA (object) + start_byte,
|
|
5137 SBYTES (object) - (size_byte - end_byte),
|
34050
|
5138 digest);
|
|
5139
|
|
5140 for (i = 0; i < 16; i++)
|
34106
|
5141 sprintf (&value[2 * i], "%02x", digest[i]);
|
34050
|
5142 value[32] = '\0';
|
|
5143
|
|
5144 return make_string (value, 32);
|
|
5145 }
|
|
5146
|
23208
|
5147
|
21514
|
5148 void
|
211
|
5149 syms_of_fns ()
|
|
5150 {
|
25005
|
5151 /* Hash table stuff. */
|
|
5152 Qhash_table_p = intern ("hash-table-p");
|
|
5153 staticpro (&Qhash_table_p);
|
|
5154 Qeq = intern ("eq");
|
|
5155 staticpro (&Qeq);
|
|
5156 Qeql = intern ("eql");
|
|
5157 staticpro (&Qeql);
|
|
5158 Qequal = intern ("equal");
|
|
5159 staticpro (&Qequal);
|
|
5160 QCtest = intern (":test");
|
|
5161 staticpro (&QCtest);
|
|
5162 QCsize = intern (":size");
|
|
5163 staticpro (&QCsize);
|
|
5164 QCrehash_size = intern (":rehash-size");
|
|
5165 staticpro (&QCrehash_size);
|
|
5166 QCrehash_threshold = intern (":rehash-threshold");
|
|
5167 staticpro (&QCrehash_threshold);
|
25455
|
5168 QCweakness = intern (":weakness");
|
|
5169 staticpro (&QCweakness);
|
25365
|
5170 Qkey = intern ("key");
|
|
5171 staticpro (&Qkey);
|
|
5172 Qvalue = intern ("value");
|
|
5173 staticpro (&Qvalue);
|
25005
|
5174 Qhash_table_test = intern ("hash-table-test");
|
|
5175 staticpro (&Qhash_table_test);
|
30496
|
5176 Qkey_or_value = intern ("key-or-value");
|
|
5177 staticpro (&Qkey_or_value);
|
|
5178 Qkey_and_value = intern ("key-and-value");
|
|
5179 staticpro (&Qkey_and_value);
|
25005
|
5180
|
|
5181 defsubr (&Ssxhash);
|
|
5182 defsubr (&Smake_hash_table);
|
25365
|
5183 defsubr (&Scopy_hash_table);
|
25005
|
5184 defsubr (&Shash_table_count);
|
|
5185 defsubr (&Shash_table_rehash_size);
|
|
5186 defsubr (&Shash_table_rehash_threshold);
|
|
5187 defsubr (&Shash_table_size);
|
|
5188 defsubr (&Shash_table_test);
|
25495
|
5189 defsubr (&Shash_table_weakness);
|
25005
|
5190 defsubr (&Shash_table_p);
|
|
5191 defsubr (&Sclrhash);
|
|
5192 defsubr (&Sgethash);
|
|
5193 defsubr (&Sputhash);
|
|
5194 defsubr (&Sremhash);
|
|
5195 defsubr (&Smaphash);
|
|
5196 defsubr (&Sdefine_hash_table_test);
|
30597
2cb00e0bf8d5
(Fmake_hash_table): Add missing `\n\' to end of line in docstring.
Noah Friedman <friedman@splode.com>
diff
changeset
|
5197
|
211
|
5198 Qstring_lessp = intern ("string-lessp");
|
|
5199 staticpro (&Qstring_lessp);
|
2546
|
5200 Qprovide = intern ("provide");
|
|
5201 staticpro (&Qprovide);
|
|
5202 Qrequire = intern ("require");
|
|
5203 staticpro (&Qrequire);
|
4456
|
5204 Qyes_or_no_p_history = intern ("yes-or-no-p-history");
|
|
5205 staticpro (&Qyes_or_no_p_history);
|
14456
|
5206 Qcursor_in_echo_area = intern ("cursor-in-echo-area");
|
|
5207 staticpro (&Qcursor_in_echo_area);
|
20004
|
5208 Qwidget_type = intern ("widget-type");
|
|
5209 staticpro (&Qwidget_type);
|
211
|
5210
|
20667
|
5211 staticpro (&string_char_byte_cache_string);
|
|
5212 string_char_byte_cache_string = Qnil;
|
|
5213
|
40474
|
5214 require_nesting_list = Qnil;
|
|
5215 staticpro (&require_nesting_list);
|
|
5216
|
14486
|
5217 Fset (Qyes_or_no_p_history, Qnil);
|
|
5218
|
39977
|
5219 DEFVAR_LISP ("features", &Vfeatures,
|
73686
|
5220 doc: /* A list of symbols which are the features of the executing Emacs.
|
39899
|
5221 Used by `featurep' and `require', and altered by `provide'. */);
|
64774
|
5222 Vfeatures = Fcons (intern ("emacs"), Qnil);
|
39850
|
5223 Qsubfeatures = intern ("subfeatures");
|
|
5224 staticpro (&Qsubfeatures);
|
211
|
5225
|
49081
|
5226 #ifdef HAVE_LANGINFO_CODESET
|
|
5227 Qcodeset = intern ("codeset");
|
|
5228 staticpro (&Qcodeset);
|
|
5229 Qdays = intern ("days");
|
|
5230 staticpro (&Qdays);
|
|
5231 Qmonths = intern ("months");
|
|
5232 staticpro (&Qmonths);
|
|
5233 Qpaper = intern ("paper");
|
|
5234 staticpro (&Qpaper);
|
|
5235 #endif /* HAVE_LANGINFO_CODESET */
|
|
5236
|
39977
|
5237 DEFVAR_BOOL ("use-dialog-box", &use_dialog_box,
|
|
5238 doc: /* *Non-nil means mouse commands use dialog boxes to ask questions.
|
44712
|
5239 This applies to `y-or-n-p' and `yes-or-no-p' questions asked by commands
|
97454
|
5240 invoked by mouse clicks and mouse menu items.
|
|
5241
|
|
5242 On some platforms, file selection dialogs are also enabled if this is
|
|
5243 non-nil. */);
|
18531
|
5244 use_dialog_box = 1;
|
|
5245
|
53189
|
5246 DEFVAR_BOOL ("use-file-dialog", &use_file_dialog,
|
|
5247 doc: /* *Non-nil means mouse commands use a file dialog to ask for files.
|
79868
|
5248 This applies to commands from menus and tool bar buttons even when
|
|
5249 they are initiated from the keyboard. The value of `use-dialog-box'
|
|
5250 takes precedence over this variable, so a file dialog is only used if
|
|
5251 both `use-dialog-box' and this variable are non-nil. */);
|
53189
|
5252 use_file_dialog = 1;
|
53255
|
5253
|
211
|
5254 defsubr (&Sidentity);
|
|
5255 defsubr (&Srandom);
|
|
5256 defsubr (&Slength);
|
12466
|
5257 defsubr (&Ssafe_length);
|
20864
|
5258 defsubr (&Sstring_bytes);
|
211
|
5259 defsubr (&Sstring_equal);
|
21671
|
5260 defsubr (&Scompare_strings);
|
211
|
5261 defsubr (&Sstring_lessp);
|
|
5262 defsubr (&Sappend);
|
|
5263 defsubr (&Sconcat);
|
|
5264 defsubr (&Svconcat);
|
|
5265 defsubr (&Scopy_sequence);
|
20667
|
5266 defsubr (&Sstring_make_multibyte);
|
|
5267 defsubr (&Sstring_make_unibyte);
|
20813
|
5268 defsubr (&Sstring_as_multibyte);
|
|
5269 defsubr (&Sstring_as_unibyte);
|
49656
|
5270 defsubr (&Sstring_to_multibyte);
|
96248
|
5271 defsubr (&Sstring_to_unibyte);
|
211
|
5272 defsubr (&Scopy_alist);
|
|
5273 defsubr (&Ssubstring);
|
44159
|
5274 defsubr (&Ssubstring_no_properties);
|
211
|
5275 defsubr (&Snthcdr);
|
|
5276 defsubr (&Snth);
|
|
5277 defsubr (&Selt);
|
|
5278 defsubr (&Smember);
|
|
5279 defsubr (&Smemq);
|
73029
|
5280 defsubr (&Smemql);
|
211
|
5281 defsubr (&Sassq);
|
|
5282 defsubr (&Sassoc);
|
|
5283 defsubr (&Srassq);
|
10588
|
5284 defsubr (&Srassoc);
|
211
|
5285 defsubr (&Sdelq);
|
414
|
5286 defsubr (&Sdelete);
|
211
|
5287 defsubr (&Snreverse);
|
|
5288 defsubr (&Sreverse);
|
|
5289 defsubr (&Ssort);
|
11130
|
5290 defsubr (&Splist_get);
|
211
|
5291 defsubr (&Sget);
|
11130
|
5292 defsubr (&Splist_put);
|
211
|
5293 defsubr (&Sput);
|
44159
|
5294 defsubr (&Slax_plist_get);
|
|
5295 defsubr (&Slax_plist_put);
|
54987
|
5296 defsubr (&Seql);
|
211
|
5297 defsubr (&Sequal);
|
54373
|
5298 defsubr (&Sequal_including_properties);
|
211
|
5299 defsubr (&Sfillarray);
|
52075
|
5300 defsubr (&Sclear_string);
|
211
|
5301 defsubr (&Snconc);
|
|
5302 defsubr (&Smapcar);
|
28666
|
5303 defsubr (&Smapc);
|
211
|
5304 defsubr (&Smapconcat);
|
|
5305 defsubr (&Sy_or_n_p);
|
|
5306 defsubr (&Syes_or_no_p);
|
|
5307 defsubr (&Sload_average);
|
|
5308 defsubr (&Sfeaturep);
|
|
5309 defsubr (&Srequire);
|
|
5310 defsubr (&Sprovide);
|
29953
|
5311 defsubr (&Splist_member);
|
20004
|
5312 defsubr (&Swidget_put);
|
|
5313 defsubr (&Swidget_get);
|
|
5314 defsubr (&Swidget_apply);
|
23208
|
5315 defsubr (&Sbase64_encode_region);
|
|
5316 defsubr (&Sbase64_decode_region);
|
|
5317 defsubr (&Sbase64_encode_string);
|
|
5318 defsubr (&Sbase64_decode_string);
|
34050
|
5319 defsubr (&Smd5);
|
51976
|
5320 defsubr (&Slocale_info);
|
211
|
5321 }
|
25005
|
5322
|
|
5323
|
|
5324 void
|
|
5325 init_fns ()
|
|
5326 {
|
|
5327 }
|
52401
|
5328
|
|
5329 /* arch-tag: 787f8219-5b74-46bd-8469-7e1cc475fa31
|
|
5330 (do not change this comment) */
|