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