|
211
|
1 /* Random utility Lisp functions.
|
|
7307
|
2 Copyright (C) 1985, 1986, 1987, 1993, 1994 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
|
|
|
8 the Free Software Foundation; either version 1, or (at your option)
|
|
|
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
|
|
|
18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
|
|
|
19
|
|
|
20
|
|
4696
|
21 #include <config.h>
|
|
211
|
22
|
|
|
23 /* Note on some machines this defines `vector' as a typedef,
|
|
|
24 so make sure we don't use that name in this file. */
|
|
|
25 #undef vector
|
|
|
26 #define vector *****
|
|
|
27
|
|
|
28 #include "lisp.h"
|
|
|
29 #include "commands.h"
|
|
|
30
|
|
|
31 #include "buffer.h"
|
|
1513
|
32 #include "keyboard.h"
|
|
4004
|
33 #include "intervals.h"
|
|
211
|
34
|
|
2546
|
35 Lisp_Object Qstring_lessp, Qprovide, Qrequire;
|
|
4456
|
36 Lisp_Object Qyes_or_no_p_history;
|
|
211
|
37
|
|
399
|
38 static Lisp_Object internal_equal ();
|
|
|
39
|
|
211
|
40 DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
|
|
|
41 "Return the argument unchanged.")
|
|
|
42 (arg)
|
|
|
43 Lisp_Object arg;
|
|
|
44 {
|
|
|
45 return arg;
|
|
|
46 }
|
|
|
47
|
|
|
48 DEFUN ("random", Frandom, Srandom, 0, 1, 0,
|
|
|
49 "Return a pseudo-random number.\n\
|
|
|
50 On most systems all integers representable in Lisp are equally likely.\n\
|
|
|
51 This is 24 bits' worth.\n\
|
|
|
52 With argument N, return random number in interval [0,N).\n\
|
|
|
53 With argument t, set the random number seed from the current time and pid.")
|
|
1743
|
54 (limit)
|
|
|
55 Lisp_Object limit;
|
|
211
|
56 {
|
|
|
57 int val;
|
|
6376
|
58 unsigned long denominator;
|
|
211
|
59 extern long random ();
|
|
|
60 extern srandom ();
|
|
|
61 extern long time ();
|
|
|
62
|
|
1743
|
63 if (EQ (limit, Qt))
|
|
211
|
64 srandom (getpid () + time (0));
|
|
6376
|
65 if (XTYPE (limit) == Lisp_Int && XINT (limit) > 0)
|
|
211
|
66 {
|
|
8388
|
67 if (XINT (limit) >= 0x40000000)
|
|
|
68 /* This case may occur on 64-bit machines. */
|
|
|
69 val = random () % XINT (limit);
|
|
|
70 else
|
|
|
71 {
|
|
|
72 /* Try to take our random number from the higher bits of VAL,
|
|
|
73 not the lower, since (says Gentzel) the low bits of `random'
|
|
|
74 are less random than the higher ones. We do this by using the
|
|
|
75 quotient rather than the remainder. At the high end of the RNG
|
|
|
76 it's possible to get a quotient larger than limit; discarding
|
|
|
77 these values eliminates the bias that would otherwise appear
|
|
|
78 when using a large limit. */
|
|
|
79 denominator = (unsigned long)0x40000000 / XFASTINT (limit);
|
|
|
80 do
|
|
|
81 val = (random () & 0x3fffffff) / denominator;
|
|
|
82 while (val >= limit);
|
|
|
83 }
|
|
211
|
84 }
|
|
6376
|
85 else
|
|
|
86 val = random ();
|
|
211
|
87 return make_number (val);
|
|
|
88 }
|
|
|
89
|
|
|
90 /* Random data-structure functions */
|
|
|
91
|
|
|
92 DEFUN ("length", Flength, Slength, 1, 1, 0,
|
|
|
93 "Return the length of vector, list or string SEQUENCE.\n\
|
|
|
94 A byte-code function object is also allowed.")
|
|
|
95 (obj)
|
|
|
96 register Lisp_Object obj;
|
|
|
97 {
|
|
|
98 register Lisp_Object tail, val;
|
|
|
99 register int i;
|
|
|
100
|
|
|
101 retry:
|
|
|
102 if (XTYPE (obj) == Lisp_Vector || XTYPE (obj) == Lisp_String
|
|
|
103 || XTYPE (obj) == Lisp_Compiled)
|
|
|
104 return Farray_length (obj);
|
|
|
105 else if (CONSP (obj))
|
|
|
106 {
|
|
485
|
107 for (i = 0, tail = obj; !NILP(tail); i++)
|
|
211
|
108 {
|
|
|
109 QUIT;
|
|
|
110 tail = Fcdr (tail);
|
|
|
111 }
|
|
|
112
|
|
|
113 XFASTINT (val) = i;
|
|
|
114 return val;
|
|
|
115 }
|
|
485
|
116 else if (NILP(obj))
|
|
211
|
117 {
|
|
|
118 XFASTINT (val) = 0;
|
|
|
119 return val;
|
|
|
120 }
|
|
|
121 else
|
|
|
122 {
|
|
|
123 obj = wrong_type_argument (Qsequencep, obj);
|
|
|
124 goto retry;
|
|
|
125 }
|
|
|
126 }
|
|
|
127
|
|
|
128 DEFUN ("string-equal", Fstring_equal, Sstring_equal, 2, 2, 0,
|
|
|
129 "T if two strings have identical contents.\n\
|
|
|
130 Case is significant.\n\
|
|
|
131 Symbols are also allowed; their print names are used instead.")
|
|
|
132 (s1, s2)
|
|
|
133 register Lisp_Object s1, s2;
|
|
|
134 {
|
|
|
135 if (XTYPE (s1) == Lisp_Symbol)
|
|
|
136 XSETSTRING (s1, XSYMBOL (s1)->name), XSETTYPE (s1, Lisp_String);
|
|
|
137 if (XTYPE (s2) == Lisp_Symbol)
|
|
|
138 XSETSTRING (s2, XSYMBOL (s2)->name), XSETTYPE (s2, Lisp_String);
|
|
|
139 CHECK_STRING (s1, 0);
|
|
|
140 CHECK_STRING (s2, 1);
|
|
|
141
|
|
|
142 if (XSTRING (s1)->size != XSTRING (s2)->size ||
|
|
|
143 bcmp (XSTRING (s1)->data, XSTRING (s2)->data, XSTRING (s1)->size))
|
|
|
144 return Qnil;
|
|
|
145 return Qt;
|
|
|
146 }
|
|
|
147
|
|
|
148 DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0,
|
|
|
149 "T if first arg string is less than second in lexicographic order.\n\
|
|
|
150 Case is significant.\n\
|
|
|
151 Symbols are also allowed; their print names are used instead.")
|
|
|
152 (s1, s2)
|
|
|
153 register Lisp_Object s1, s2;
|
|
|
154 {
|
|
|
155 register int i;
|
|
|
156 register unsigned char *p1, *p2;
|
|
|
157 register int end;
|
|
|
158
|
|
|
159 if (XTYPE (s1) == Lisp_Symbol)
|
|
|
160 XSETSTRING (s1, XSYMBOL (s1)->name), XSETTYPE (s1, Lisp_String);
|
|
|
161 if (XTYPE (s2) == Lisp_Symbol)
|
|
|
162 XSETSTRING (s2, XSYMBOL (s2)->name), XSETTYPE (s2, Lisp_String);
|
|
|
163 CHECK_STRING (s1, 0);
|
|
|
164 CHECK_STRING (s2, 1);
|
|
|
165
|
|
|
166 p1 = XSTRING (s1)->data;
|
|
|
167 p2 = XSTRING (s2)->data;
|
|
|
168 end = XSTRING (s1)->size;
|
|
|
169 if (end > XSTRING (s2)->size)
|
|
|
170 end = XSTRING (s2)->size;
|
|
|
171
|
|
|
172 for (i = 0; i < end; i++)
|
|
|
173 {
|
|
|
174 if (p1[i] != p2[i])
|
|
|
175 return p1[i] < p2[i] ? Qt : Qnil;
|
|
|
176 }
|
|
|
177 return i < XSTRING (s2)->size ? Qt : Qnil;
|
|
|
178 }
|
|
|
179
|
|
|
180 static Lisp_Object concat ();
|
|
|
181
|
|
|
182 /* ARGSUSED */
|
|
|
183 Lisp_Object
|
|
|
184 concat2 (s1, s2)
|
|
|
185 Lisp_Object s1, s2;
|
|
|
186 {
|
|
|
187 #ifdef NO_ARG_ARRAY
|
|
|
188 Lisp_Object args[2];
|
|
|
189 args[0] = s1;
|
|
|
190 args[1] = s2;
|
|
|
191 return concat (2, args, Lisp_String, 0);
|
|
|
192 #else
|
|
|
193 return concat (2, &s1, Lisp_String, 0);
|
|
|
194 #endif /* NO_ARG_ARRAY */
|
|
|
195 }
|
|
|
196
|
|
|
197 DEFUN ("append", Fappend, Sappend, 0, MANY, 0,
|
|
|
198 "Concatenate all the arguments and make the result a list.\n\
|
|
|
199 The result is a list whose elements are the elements of all the arguments.\n\
|
|
|
200 Each argument may be a list, vector or string.\n\
|
|
1037
|
201 The last argument is not copied, just used as the tail of the new list.")
|
|
211
|
202 (nargs, args)
|
|
|
203 int nargs;
|
|
|
204 Lisp_Object *args;
|
|
|
205 {
|
|
|
206 return concat (nargs, args, Lisp_Cons, 1);
|
|
|
207 }
|
|
|
208
|
|
|
209 DEFUN ("concat", Fconcat, Sconcat, 0, MANY, 0,
|
|
|
210 "Concatenate all the arguments and make the result a string.\n\
|
|
|
211 The result is a string whose elements are the elements of all the arguments.\n\
|
|
5664
|
212 Each argument may be a string, a list of characters (integers),\n\
|
|
|
213 or a vector of characters (integers).")
|
|
211
|
214 (nargs, args)
|
|
|
215 int nargs;
|
|
|
216 Lisp_Object *args;
|
|
|
217 {
|
|
|
218 return concat (nargs, args, Lisp_String, 0);
|
|
|
219 }
|
|
|
220
|
|
|
221 DEFUN ("vconcat", Fvconcat, Svconcat, 0, MANY, 0,
|
|
|
222 "Concatenate all the arguments and make the result a vector.\n\
|
|
|
223 The result is a vector whose elements are the elements of all the arguments.\n\
|
|
|
224 Each argument may be a list, vector or string.")
|
|
|
225 (nargs, args)
|
|
|
226 int nargs;
|
|
|
227 Lisp_Object *args;
|
|
|
228 {
|
|
|
229 return concat (nargs, args, Lisp_Vector, 0);
|
|
|
230 }
|
|
|
231
|
|
|
232 DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0,
|
|
|
233 "Return a copy of a list, vector or string.\n\
|
|
|
234 The elements of a list or vector are not copied; they are shared\n\
|
|
|
235 with the original.")
|
|
|
236 (arg)
|
|
|
237 Lisp_Object arg;
|
|
|
238 {
|
|
485
|
239 if (NILP (arg)) return arg;
|
|
211
|
240 if (!CONSP (arg) && XTYPE (arg) != Lisp_Vector && XTYPE (arg) != Lisp_String)
|
|
|
241 arg = wrong_type_argument (Qsequencep, arg);
|
|
|
242 return concat (1, &arg, CONSP (arg) ? Lisp_Cons : XTYPE (arg), 0);
|
|
|
243 }
|
|
|
244
|
|
|
245 static Lisp_Object
|
|
|
246 concat (nargs, args, target_type, last_special)
|
|
|
247 int nargs;
|
|
|
248 Lisp_Object *args;
|
|
|
249 enum Lisp_Type target_type;
|
|
|
250 int last_special;
|
|
|
251 {
|
|
|
252 Lisp_Object val;
|
|
|
253 Lisp_Object len;
|
|
|
254 register Lisp_Object tail;
|
|
|
255 register Lisp_Object this;
|
|
|
256 int toindex;
|
|
|
257 register int leni;
|
|
|
258 register int argnum;
|
|
|
259 Lisp_Object last_tail;
|
|
|
260 Lisp_Object prev;
|
|
|
261
|
|
|
262 /* In append, the last arg isn't treated like the others */
|
|
|
263 if (last_special && nargs > 0)
|
|
|
264 {
|
|
|
265 nargs--;
|
|
|
266 last_tail = args[nargs];
|
|
|
267 }
|
|
|
268 else
|
|
|
269 last_tail = Qnil;
|
|
|
270
|
|
|
271 for (argnum = 0; argnum < nargs; argnum++)
|
|
|
272 {
|
|
|
273 this = args[argnum];
|
|
485
|
274 if (!(CONSP (this) || NILP (this)
|
|
211
|
275 || XTYPE (this) == Lisp_Vector || XTYPE (this) == Lisp_String
|
|
|
276 || XTYPE (this) == Lisp_Compiled))
|
|
|
277 {
|
|
|
278 if (XTYPE (this) == Lisp_Int)
|
|
2429
|
279 args[argnum] = Fnumber_to_string (this);
|
|
211
|
280 else
|
|
|
281 args[argnum] = wrong_type_argument (Qsequencep, this);
|
|
|
282 }
|
|
|
283 }
|
|
|
284
|
|
|
285 for (argnum = 0, leni = 0; argnum < nargs; argnum++)
|
|
|
286 {
|
|
|
287 this = args[argnum];
|
|
|
288 len = Flength (this);
|
|
|
289 leni += XFASTINT (len);
|
|
|
290 }
|
|
|
291
|
|
|
292 XFASTINT (len) = leni;
|
|
|
293
|
|
|
294 if (target_type == Lisp_Cons)
|
|
|
295 val = Fmake_list (len, Qnil);
|
|
|
296 else if (target_type == Lisp_Vector)
|
|
|
297 val = Fmake_vector (len, Qnil);
|
|
|
298 else
|
|
|
299 val = Fmake_string (len, len);
|
|
|
300
|
|
|
301 /* In append, if all but last arg are nil, return last arg */
|
|
|
302 if (target_type == Lisp_Cons && EQ (val, Qnil))
|
|
|
303 return last_tail;
|
|
|
304
|
|
|
305 if (CONSP (val))
|
|
|
306 tail = val, toindex = -1; /* -1 in toindex is flag we are making a list */
|
|
|
307 else
|
|
|
308 toindex = 0;
|
|
|
309
|
|
|
310 prev = Qnil;
|
|
|
311
|
|
|
312 for (argnum = 0; argnum < nargs; argnum++)
|
|
|
313 {
|
|
|
314 Lisp_Object thislen;
|
|
|
315 int thisleni;
|
|
|
316 register int thisindex = 0;
|
|
|
317
|
|
|
318 this = args[argnum];
|
|
|
319 if (!CONSP (this))
|
|
|
320 thislen = Flength (this), thisleni = XINT (thislen);
|
|
|
321
|
|
4004
|
322 if (XTYPE (this) == Lisp_String && XTYPE (val) == Lisp_String
|
|
|
323 && ! NULL_INTERVAL_P (XSTRING (this)->intervals))
|
|
|
324 {
|
|
|
325 copy_text_properties (make_number (0), thislen, this,
|
|
|
326 make_number (toindex), val, Qnil);
|
|
|
327 }
|
|
|
328
|
|
211
|
329 while (1)
|
|
|
330 {
|
|
|
331 register Lisp_Object elt;
|
|
|
332
|
|
4004
|
333 /* Fetch next element of `this' arg into `elt', or break if
|
|
|
334 `this' is exhausted. */
|
|
485
|
335 if (NILP (this)) break;
|
|
211
|
336 if (CONSP (this))
|
|
|
337 elt = Fcar (this), this = Fcdr (this);
|
|
|
338 else
|
|
|
339 {
|
|
|
340 if (thisindex >= thisleni) break;
|
|
|
341 if (XTYPE (this) == Lisp_String)
|
|
|
342 XFASTINT (elt) = XSTRING (this)->data[thisindex++];
|
|
|
343 else
|
|
|
344 elt = XVECTOR (this)->contents[thisindex++];
|
|
|
345 }
|
|
|
346
|
|
|
347 /* Store into result */
|
|
|
348 if (toindex < 0)
|
|
|
349 {
|
|
|
350 XCONS (tail)->car = elt;
|
|
|
351 prev = tail;
|
|
|
352 tail = XCONS (tail)->cdr;
|
|
|
353 }
|
|
|
354 else if (XTYPE (val) == Lisp_Vector)
|
|
|
355 XVECTOR (val)->contents[toindex++] = elt;
|
|
|
356 else
|
|
|
357 {
|
|
|
358 while (XTYPE (elt) != Lisp_Int)
|
|
|
359 elt = wrong_type_argument (Qintegerp, elt);
|
|
|
360 {
|
|
|
361 #ifdef MASSC_REGISTER_BUG
|
|
|
362 /* Even removing all "register"s doesn't disable this bug!
|
|
|
363 Nothing simpler than this seems to work. */
|
|
|
364 unsigned char *p = & XSTRING (val)->data[toindex++];
|
|
|
365 *p = XINT (elt);
|
|
|
366 #else
|
|
|
367 XSTRING (val)->data[toindex++] = XINT (elt);
|
|
|
368 #endif
|
|
|
369 }
|
|
|
370 }
|
|
|
371 }
|
|
|
372 }
|
|
485
|
373 if (!NILP (prev))
|
|
211
|
374 XCONS (prev)->cdr = last_tail;
|
|
|
375
|
|
|
376 return val;
|
|
|
377 }
|
|
|
378
|
|
|
379 DEFUN ("copy-alist", Fcopy_alist, Scopy_alist, 1, 1, 0,
|
|
|
380 "Return a copy of ALIST.\n\
|
|
|
381 This is an alist which represents the same mapping from objects to objects,\n\
|
|
|
382 but does not share the alist structure with ALIST.\n\
|
|
|
383 The objects mapped (cars and cdrs of elements of the alist)\n\
|
|
|
384 are shared, however.\n\
|
|
|
385 Elements of ALIST that are not conses are also shared.")
|
|
|
386 (alist)
|
|
|
387 Lisp_Object alist;
|
|
|
388 {
|
|
|
389 register Lisp_Object tem;
|
|
|
390
|
|
|
391 CHECK_LIST (alist, 0);
|
|
485
|
392 if (NILP (alist))
|
|
211
|
393 return alist;
|
|
|
394 alist = concat (1, &alist, Lisp_Cons, 0);
|
|
|
395 for (tem = alist; CONSP (tem); tem = XCONS (tem)->cdr)
|
|
|
396 {
|
|
|
397 register Lisp_Object car;
|
|
|
398 car = XCONS (tem)->car;
|
|
|
399
|
|
|
400 if (CONSP (car))
|
|
|
401 XCONS (tem)->car = Fcons (XCONS (car)->car, XCONS (car)->cdr);
|
|
|
402 }
|
|
|
403 return alist;
|
|
|
404 }
|
|
|
405
|
|
|
406 DEFUN ("substring", Fsubstring, Ssubstring, 2, 3, 0,
|
|
|
407 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
|
|
|
408 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
|
|
|
409 If FROM or TO is negative, it counts from the end.")
|
|
|
410 (string, from, to)
|
|
|
411 Lisp_Object string;
|
|
|
412 register Lisp_Object from, to;
|
|
|
413 {
|
|
4004
|
414 Lisp_Object res;
|
|
|
415
|
|
211
|
416 CHECK_STRING (string, 0);
|
|
|
417 CHECK_NUMBER (from, 1);
|
|
485
|
418 if (NILP (to))
|
|
211
|
419 to = Flength (string);
|
|
|
420 else
|
|
|
421 CHECK_NUMBER (to, 2);
|
|
|
422
|
|
|
423 if (XINT (from) < 0)
|
|
|
424 XSETINT (from, XINT (from) + XSTRING (string)->size);
|
|
|
425 if (XINT (to) < 0)
|
|
|
426 XSETINT (to, XINT (to) + XSTRING (string)->size);
|
|
|
427 if (!(0 <= XINT (from) && XINT (from) <= XINT (to)
|
|
|
428 && XINT (to) <= XSTRING (string)->size))
|
|
|
429 args_out_of_range_3 (string, from, to);
|
|
|
430
|
|
4004
|
431 res = make_string (XSTRING (string)->data + XINT (from),
|
|
|
432 XINT (to) - XINT (from));
|
|
|
433 copy_text_properties (from, to, string, make_number (0), res, Qnil);
|
|
|
434 return res;
|
|
211
|
435 }
|
|
|
436
|
|
|
437 DEFUN ("nthcdr", Fnthcdr, Snthcdr, 2, 2, 0,
|
|
|
438 "Take cdr N times on LIST, returns the result.")
|
|
|
439 (n, list)
|
|
|
440 Lisp_Object n;
|
|
|
441 register Lisp_Object list;
|
|
|
442 {
|
|
|
443 register int i, num;
|
|
|
444 CHECK_NUMBER (n, 0);
|
|
|
445 num = XINT (n);
|
|
485
|
446 for (i = 0; i < num && !NILP (list); i++)
|
|
211
|
447 {
|
|
|
448 QUIT;
|
|
|
449 list = Fcdr (list);
|
|
|
450 }
|
|
|
451 return list;
|
|
|
452 }
|
|
|
453
|
|
|
454 DEFUN ("nth", Fnth, Snth, 2, 2, 0,
|
|
|
455 "Return the Nth element of LIST.\n\
|
|
|
456 N counts from zero. If LIST is not that long, nil is returned.")
|
|
|
457 (n, list)
|
|
|
458 Lisp_Object n, list;
|
|
|
459 {
|
|
|
460 return Fcar (Fnthcdr (n, list));
|
|
|
461 }
|
|
|
462
|
|
|
463 DEFUN ("elt", Felt, Selt, 2, 2, 0,
|
|
|
464 "Return element of SEQUENCE at index N.")
|
|
|
465 (seq, n)
|
|
|
466 register Lisp_Object seq, n;
|
|
|
467 {
|
|
|
468 CHECK_NUMBER (n, 0);
|
|
|
469 while (1)
|
|
|
470 {
|
|
485
|
471 if (XTYPE (seq) == Lisp_Cons || NILP (seq))
|
|
211
|
472 return Fcar (Fnthcdr (n, seq));
|
|
399
|
473 else if (XTYPE (seq) == Lisp_String
|
|
|
474 || XTYPE (seq) == Lisp_Vector)
|
|
211
|
475 return Faref (seq, n);
|
|
|
476 else
|
|
|
477 seq = wrong_type_argument (Qsequencep, seq);
|
|
|
478 }
|
|
|
479 }
|
|
|
480
|
|
|
481 DEFUN ("member", Fmember, Smember, 2, 2, 0,
|
|
6990
|
482 "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
|
|
211
|
483 The value is actually the tail of LIST whose car is ELT.")
|
|
|
484 (elt, list)
|
|
|
485 register Lisp_Object elt;
|
|
|
486 Lisp_Object list;
|
|
|
487 {
|
|
|
488 register Lisp_Object tail;
|
|
485
|
489 for (tail = list; !NILP (tail); tail = Fcdr (tail))
|
|
211
|
490 {
|
|
|
491 register Lisp_Object tem;
|
|
|
492 tem = Fcar (tail);
|
|
485
|
493 if (! NILP (Fequal (elt, tem)))
|
|
211
|
494 return tail;
|
|
|
495 QUIT;
|
|
|
496 }
|
|
|
497 return Qnil;
|
|
|
498 }
|
|
|
499
|
|
|
500 DEFUN ("memq", Fmemq, Smemq, 2, 2, 0,
|
|
|
501 "Return non-nil if ELT is an element of LIST. Comparison done with EQ.\n\
|
|
|
502 The value is actually the tail of LIST whose car is ELT.")
|
|
|
503 (elt, list)
|
|
|
504 register Lisp_Object elt;
|
|
|
505 Lisp_Object list;
|
|
|
506 {
|
|
|
507 register Lisp_Object tail;
|
|
485
|
508 for (tail = list; !NILP (tail); tail = Fcdr (tail))
|
|
211
|
509 {
|
|
|
510 register Lisp_Object tem;
|
|
|
511 tem = Fcar (tail);
|
|
|
512 if (EQ (elt, tem)) return tail;
|
|
|
513 QUIT;
|
|
|
514 }
|
|
|
515 return Qnil;
|
|
|
516 }
|
|
|
517
|
|
|
518 DEFUN ("assq", Fassq, Sassq, 2, 2, 0,
|
|
5661
|
519 "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
|
|
|
520 The value is actually the element of LIST whose car is KEY.\n\
|
|
211
|
521 Elements of LIST that are not conses are ignored.")
|
|
|
522 (key, list)
|
|
|
523 register Lisp_Object key;
|
|
|
524 Lisp_Object list;
|
|
|
525 {
|
|
|
526 register Lisp_Object tail;
|
|
485
|
527 for (tail = list; !NILP (tail); tail = Fcdr (tail))
|
|
211
|
528 {
|
|
|
529 register Lisp_Object elt, tem;
|
|
|
530 elt = Fcar (tail);
|
|
|
531 if (!CONSP (elt)) continue;
|
|
|
532 tem = Fcar (elt);
|
|
|
533 if (EQ (key, tem)) return elt;
|
|
|
534 QUIT;
|
|
|
535 }
|
|
|
536 return Qnil;
|
|
|
537 }
|
|
|
538
|
|
|
539 /* Like Fassq but never report an error and do not allow quits.
|
|
|
540 Use only on lists known never to be circular. */
|
|
|
541
|
|
|
542 Lisp_Object
|
|
|
543 assq_no_quit (key, list)
|
|
|
544 register Lisp_Object key;
|
|
|
545 Lisp_Object list;
|
|
|
546 {
|
|
|
547 register Lisp_Object tail;
|
|
|
548 for (tail = list; CONSP (tail); tail = Fcdr (tail))
|
|
|
549 {
|
|
|
550 register Lisp_Object elt, tem;
|
|
|
551 elt = Fcar (tail);
|
|
|
552 if (!CONSP (elt)) continue;
|
|
|
553 tem = Fcar (elt);
|
|
|
554 if (EQ (key, tem)) return elt;
|
|
|
555 }
|
|
|
556 return Qnil;
|
|
|
557 }
|
|
|
558
|
|
|
559 DEFUN ("assoc", Fassoc, Sassoc, 2, 2, 0,
|
|
5661
|
560 "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
|
|
|
561 The value is actually the element of LIST whose car is KEY.")
|
|
211
|
562 (key, list)
|
|
|
563 register Lisp_Object key;
|
|
|
564 Lisp_Object list;
|
|
|
565 {
|
|
|
566 register Lisp_Object tail;
|
|
485
|
567 for (tail = list; !NILP (tail); tail = Fcdr (tail))
|
|
211
|
568 {
|
|
|
569 register Lisp_Object elt, tem;
|
|
|
570 elt = Fcar (tail);
|
|
|
571 if (!CONSP (elt)) continue;
|
|
|
572 tem = Fequal (Fcar (elt), key);
|
|
485
|
573 if (!NILP (tem)) return elt;
|
|
211
|
574 QUIT;
|
|
|
575 }
|
|
|
576 return Qnil;
|
|
|
577 }
|
|
|
578
|
|
|
579 DEFUN ("rassq", Frassq, Srassq, 2, 2, 0,
|
|
|
580 "Return non-nil if ELT is `eq' to the cdr of an element of LIST.\n\
|
|
|
581 The value is actually the element of LIST whose cdr is ELT.")
|
|
|
582 (key, list)
|
|
|
583 register Lisp_Object key;
|
|
|
584 Lisp_Object list;
|
|
|
585 {
|
|
|
586 register Lisp_Object tail;
|
|
485
|
587 for (tail = list; !NILP (tail); tail = Fcdr (tail))
|
|
211
|
588 {
|
|
|
589 register Lisp_Object elt, tem;
|
|
|
590 elt = Fcar (tail);
|
|
|
591 if (!CONSP (elt)) continue;
|
|
|
592 tem = Fcdr (elt);
|
|
|
593 if (EQ (key, tem)) return elt;
|
|
|
594 QUIT;
|
|
|
595 }
|
|
|
596 return Qnil;
|
|
|
597 }
|
|
|
598
|
|
|
599 DEFUN ("delq", Fdelq, Sdelq, 2, 2, 0,
|
|
|
600 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
|
|
|
601 The modified LIST is returned. Comparison is done with `eq'.\n\
|
|
|
602 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
|
|
|
603 therefore, write `(setq foo (delq element foo))'\n\
|
|
|
604 to be sure of changing the value of `foo'.")
|
|
|
605 (elt, list)
|
|
|
606 register Lisp_Object elt;
|
|
|
607 Lisp_Object list;
|
|
|
608 {
|
|
|
609 register Lisp_Object tail, prev;
|
|
|
610 register Lisp_Object tem;
|
|
|
611
|
|
|
612 tail = list;
|
|
|
613 prev = Qnil;
|
|
485
|
614 while (!NILP (tail))
|
|
211
|
615 {
|
|
|
616 tem = Fcar (tail);
|
|
|
617 if (EQ (elt, tem))
|
|
|
618 {
|
|
485
|
619 if (NILP (prev))
|
|
211
|
620 list = Fcdr (tail);
|
|
|
621 else
|
|
|
622 Fsetcdr (prev, Fcdr (tail));
|
|
|
623 }
|
|
|
624 else
|
|
|
625 prev = tail;
|
|
|
626 tail = Fcdr (tail);
|
|
|
627 QUIT;
|
|
|
628 }
|
|
|
629 return list;
|
|
|
630 }
|
|
|
631
|
|
414
|
632 DEFUN ("delete", Fdelete, Sdelete, 2, 2, 0,
|
|
401
|
633 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
|
|
|
634 The modified LIST is returned. Comparison is done with `equal'.\n\
|
|
6990
|
635 If the first member of LIST is ELT, deleting it is not a side effect;\n\
|
|
|
636 it is simply using a different list.\n\
|
|
|
637 Therefore, write `(setq foo (delete element foo))'\n\
|
|
401
|
638 to be sure of changing the value of `foo'.")
|
|
|
639 (elt, list)
|
|
|
640 register Lisp_Object elt;
|
|
|
641 Lisp_Object list;
|
|
|
642 {
|
|
|
643 register Lisp_Object tail, prev;
|
|
|
644 register Lisp_Object tem;
|
|
|
645
|
|
|
646 tail = list;
|
|
|
647 prev = Qnil;
|
|
485
|
648 while (!NILP (tail))
|
|
401
|
649 {
|
|
|
650 tem = Fcar (tail);
|
|
1513
|
651 if (! NILP (Fequal (elt, tem)))
|
|
401
|
652 {
|
|
485
|
653 if (NILP (prev))
|
|
401
|
654 list = Fcdr (tail);
|
|
|
655 else
|
|
|
656 Fsetcdr (prev, Fcdr (tail));
|
|
|
657 }
|
|
|
658 else
|
|
|
659 prev = tail;
|
|
|
660 tail = Fcdr (tail);
|
|
|
661 QUIT;
|
|
|
662 }
|
|
|
663 return list;
|
|
|
664 }
|
|
|
665
|
|
211
|
666 DEFUN ("nreverse", Fnreverse, Snreverse, 1, 1, 0,
|
|
|
667 "Reverse LIST by modifying cdr pointers.\n\
|
|
|
668 Returns the beginning of the reversed list.")
|
|
|
669 (list)
|
|
|
670 Lisp_Object list;
|
|
|
671 {
|
|
|
672 register Lisp_Object prev, tail, next;
|
|
|
673
|
|
485
|
674 if (NILP (list)) return list;
|
|
211
|
675 prev = Qnil;
|
|
|
676 tail = list;
|
|
485
|
677 while (!NILP (tail))
|
|
211
|
678 {
|
|
|
679 QUIT;
|
|
|
680 next = Fcdr (tail);
|
|
|
681 Fsetcdr (tail, prev);
|
|
|
682 prev = tail;
|
|
|
683 tail = next;
|
|
|
684 }
|
|
|
685 return prev;
|
|
|
686 }
|
|
|
687
|
|
|
688 DEFUN ("reverse", Freverse, Sreverse, 1, 1, 0,
|
|
|
689 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
|
|
|
690 See also the function `nreverse', which is used more often.")
|
|
|
691 (list)
|
|
|
692 Lisp_Object list;
|
|
|
693 {
|
|
|
694 Lisp_Object length;
|
|
|
695 register Lisp_Object *vec;
|
|
|
696 register Lisp_Object tail;
|
|
|
697 register int i;
|
|
|
698
|
|
|
699 length = Flength (list);
|
|
|
700 vec = (Lisp_Object *) alloca (XINT (length) * sizeof (Lisp_Object));
|
|
|
701 for (i = XINT (length) - 1, tail = list; i >= 0; i--, tail = Fcdr (tail))
|
|
|
702 vec[i] = Fcar (tail);
|
|
|
703
|
|
|
704 return Flist (XINT (length), vec);
|
|
|
705 }
|
|
|
706
|
|
|
707 Lisp_Object merge ();
|
|
|
708
|
|
|
709 DEFUN ("sort", Fsort, Ssort, 2, 2, 0,
|
|
|
710 "Sort LIST, stably, comparing elements using PREDICATE.\n\
|
|
|
711 Returns the sorted list. LIST is modified by side effects.\n\
|
|
|
712 PREDICATE is called with two elements of LIST, and should return T\n\
|
|
|
713 if the first element is \"less\" than the second.")
|
|
|
714 (list, pred)
|
|
|
715 Lisp_Object list, pred;
|
|
|
716 {
|
|
|
717 Lisp_Object front, back;
|
|
|
718 register Lisp_Object len, tem;
|
|
|
719 struct gcpro gcpro1, gcpro2;
|
|
|
720 register int length;
|
|
|
721
|
|
|
722 front = list;
|
|
|
723 len = Flength (list);
|
|
|
724 length = XINT (len);
|
|
|
725 if (length < 2)
|
|
|
726 return list;
|
|
|
727
|
|
|
728 XSETINT (len, (length / 2) - 1);
|
|
|
729 tem = Fnthcdr (len, list);
|
|
|
730 back = Fcdr (tem);
|
|
|
731 Fsetcdr (tem, Qnil);
|
|
|
732
|
|
|
733 GCPRO2 (front, back);
|
|
|
734 front = Fsort (front, pred);
|
|
|
735 back = Fsort (back, pred);
|
|
|
736 UNGCPRO;
|
|
|
737 return merge (front, back, pred);
|
|
|
738 }
|
|
|
739
|
|
|
740 Lisp_Object
|
|
|
741 merge (org_l1, org_l2, pred)
|
|
|
742 Lisp_Object org_l1, org_l2;
|
|
|
743 Lisp_Object pred;
|
|
|
744 {
|
|
|
745 Lisp_Object value;
|
|
|
746 register Lisp_Object tail;
|
|
|
747 Lisp_Object tem;
|
|
|
748 register Lisp_Object l1, l2;
|
|
|
749 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
|
|
|
750
|
|
|
751 l1 = org_l1;
|
|
|
752 l2 = org_l2;
|
|
|
753 tail = Qnil;
|
|
|
754 value = Qnil;
|
|
|
755
|
|
|
756 /* It is sufficient to protect org_l1 and org_l2.
|
|
|
757 When l1 and l2 are updated, we copy the new values
|
|
|
758 back into the org_ vars. */
|
|
|
759 GCPRO4 (org_l1, org_l2, pred, value);
|
|
|
760
|
|
|
761 while (1)
|
|
|
762 {
|
|
485
|
763 if (NILP (l1))
|
|
211
|
764 {
|
|
|
765 UNGCPRO;
|
|
485
|
766 if (NILP (tail))
|
|
211
|
767 return l2;
|
|
|
768 Fsetcdr (tail, l2);
|
|
|
769 return value;
|
|
|
770 }
|
|
485
|
771 if (NILP (l2))
|
|
211
|
772 {
|
|
|
773 UNGCPRO;
|
|
485
|
774 if (NILP (tail))
|
|
211
|
775 return l1;
|
|
|
776 Fsetcdr (tail, l1);
|
|
|
777 return value;
|
|
|
778 }
|
|
|
779 tem = call2 (pred, Fcar (l2), Fcar (l1));
|
|
485
|
780 if (NILP (tem))
|
|
211
|
781 {
|
|
|
782 tem = l1;
|
|
|
783 l1 = Fcdr (l1);
|
|
|
784 org_l1 = l1;
|
|
|
785 }
|
|
|
786 else
|
|
|
787 {
|
|
|
788 tem = l2;
|
|
|
789 l2 = Fcdr (l2);
|
|
|
790 org_l2 = l2;
|
|
|
791 }
|
|
485
|
792 if (NILP (tail))
|
|
211
|
793 value = tem;
|
|
|
794 else
|
|
|
795 Fsetcdr (tail, tem);
|
|
|
796 tail = tem;
|
|
|
797 }
|
|
|
798 }
|
|
|
799
|
|
|
800 DEFUN ("get", Fget, Sget, 2, 2, 0,
|
|
|
801 "Return the value of SYMBOL's PROPNAME property.\n\
|
|
|
802 This is the last VALUE stored with `(put SYMBOL PROPNAME VALUE)'.")
|
|
|
803 (sym, prop)
|
|
|
804 Lisp_Object sym;
|
|
|
805 register Lisp_Object prop;
|
|
|
806 {
|
|
|
807 register Lisp_Object tail;
|
|
485
|
808 for (tail = Fsymbol_plist (sym); !NILP (tail); tail = Fcdr (Fcdr (tail)))
|
|
211
|
809 {
|
|
|
810 register Lisp_Object tem;
|
|
|
811 tem = Fcar (tail);
|
|
|
812 if (EQ (prop, tem))
|
|
|
813 return Fcar (Fcdr (tail));
|
|
|
814 }
|
|
|
815 return Qnil;
|
|
|
816 }
|
|
|
817
|
|
|
818 DEFUN ("put", Fput, Sput, 3, 3, 0,
|
|
|
819 "Store SYMBOL's PROPNAME property with value VALUE.\n\
|
|
|
820 It can be retrieved with `(get SYMBOL PROPNAME)'.")
|
|
|
821 (sym, prop, val)
|
|
|
822 Lisp_Object sym;
|
|
|
823 register Lisp_Object prop;
|
|
|
824 Lisp_Object val;
|
|
|
825 {
|
|
|
826 register Lisp_Object tail, prev;
|
|
|
827 Lisp_Object newcell;
|
|
|
828 prev = Qnil;
|
|
485
|
829 for (tail = Fsymbol_plist (sym); !NILP (tail); tail = Fcdr (Fcdr (tail)))
|
|
211
|
830 {
|
|
|
831 register Lisp_Object tem;
|
|
|
832 tem = Fcar (tail);
|
|
|
833 if (EQ (prop, tem))
|
|
|
834 return Fsetcar (Fcdr (tail), val);
|
|
|
835 prev = tail;
|
|
|
836 }
|
|
|
837 newcell = Fcons (prop, Fcons (val, Qnil));
|
|
485
|
838 if (NILP (prev))
|
|
211
|
839 Fsetplist (sym, newcell);
|
|
|
840 else
|
|
|
841 Fsetcdr (Fcdr (prev), newcell);
|
|
|
842 return val;
|
|
|
843 }
|
|
|
844
|
|
|
845 DEFUN ("equal", Fequal, Sequal, 2, 2, 0,
|
|
|
846 "T if two Lisp objects have similar structure and contents.\n\
|
|
|
847 They must have the same data type.\n\
|
|
|
848 Conses are compared by comparing the cars and the cdrs.\n\
|
|
|
849 Vectors and strings are compared element by element.\n\
|
|
3379
|
850 Numbers are compared by value, but integers cannot equal floats.\n\
|
|
|
851 (Use `=' if you want integers and floats to be able to be equal.)\n\
|
|
|
852 Symbols must match exactly.")
|
|
211
|
853 (o1, o2)
|
|
|
854 register Lisp_Object o1, o2;
|
|
|
855 {
|
|
399
|
856 return internal_equal (o1, o2, 0);
|
|
|
857 }
|
|
|
858
|
|
|
859 static Lisp_Object
|
|
|
860 internal_equal (o1, o2, depth)
|
|
|
861 register Lisp_Object o1, o2;
|
|
|
862 int depth;
|
|
|
863 {
|
|
|
864 if (depth > 200)
|
|
|
865 error ("Stack overflow in equal");
|
|
211
|
866 do_cdr:
|
|
|
867 QUIT;
|
|
1821
|
868 if (EQ (o1, o2)) return Qt;
|
|
1822
|
869 #ifdef LISP_FLOAT_TYPE
|
|
3379
|
870 if (FLOATP (o1) && FLOATP (o2))
|
|
|
871 return (extract_float (o1) == extract_float (o2)) ? Qt : Qnil;
|
|
1822
|
872 #endif
|
|
211
|
873 if (XTYPE (o1) != XTYPE (o2)) return Qnil;
|
|
2782
|
874 if (XTYPE (o1) == Lisp_Cons
|
|
|
875 || XTYPE (o1) == Lisp_Overlay)
|
|
211
|
876 {
|
|
|
877 Lisp_Object v1;
|
|
1919
|
878 v1 = internal_equal (Fcar (o1), Fcar (o2), depth + 1);
|
|
485
|
879 if (NILP (v1))
|
|
211
|
880 return v1;
|
|
|
881 o1 = Fcdr (o1), o2 = Fcdr (o2);
|
|
|
882 goto do_cdr;
|
|
|
883 }
|
|
|
884 if (XTYPE (o1) == Lisp_Marker)
|
|
|
885 {
|
|
4613
|
886 return ((XMARKER (o1)->buffer == XMARKER (o2)->buffer
|
|
4616
|
887 && (XMARKER (o1)->buffer == 0
|
|
4613
|
888 || XMARKER (o1)->bufpos == XMARKER (o2)->bufpos))
|
|
|
889 ? Qt : Qnil);
|
|
211
|
890 }
|
|
1821
|
891 if (XTYPE (o1) == Lisp_Vector
|
|
|
892 || XTYPE (o1) == Lisp_Compiled)
|
|
211
|
893 {
|
|
|
894 register int index;
|
|
|
895 if (XVECTOR (o1)->size != XVECTOR (o2)->size)
|
|
|
896 return Qnil;
|
|
|
897 for (index = 0; index < XVECTOR (o1)->size; index++)
|
|
|
898 {
|
|
|
899 Lisp_Object v, v1, v2;
|
|
|
900 v1 = XVECTOR (o1)->contents [index];
|
|
|
901 v2 = XVECTOR (o2)->contents [index];
|
|
1919
|
902 v = internal_equal (v1, v2, depth + 1);
|
|
485
|
903 if (NILP (v)) return v;
|
|
211
|
904 }
|
|
|
905 return Qt;
|
|
|
906 }
|
|
|
907 if (XTYPE (o1) == Lisp_String)
|
|
|
908 {
|
|
|
909 if (XSTRING (o1)->size != XSTRING (o2)->size)
|
|
|
910 return Qnil;
|
|
|
911 if (bcmp (XSTRING (o1)->data, XSTRING (o2)->data, XSTRING (o1)->size))
|
|
|
912 return Qnil;
|
|
|
913 return Qt;
|
|
|
914 }
|
|
|
915 return Qnil;
|
|
|
916 }
|
|
|
917
|
|
|
918 DEFUN ("fillarray", Ffillarray, Sfillarray, 2, 2, 0,
|
|
|
919 "Store each element of ARRAY with ITEM. ARRAY is a vector or string.")
|
|
|
920 (array, item)
|
|
|
921 Lisp_Object array, item;
|
|
|
922 {
|
|
|
923 register int size, index, charval;
|
|
|
924 retry:
|
|
|
925 if (XTYPE (array) == Lisp_Vector)
|
|
|
926 {
|
|
|
927 register Lisp_Object *p = XVECTOR (array)->contents;
|
|
|
928 size = XVECTOR (array)->size;
|
|
|
929 for (index = 0; index < size; index++)
|
|
|
930 p[index] = item;
|
|
|
931 }
|
|
|
932 else if (XTYPE (array) == Lisp_String)
|
|
|
933 {
|
|
|
934 register unsigned char *p = XSTRING (array)->data;
|
|
|
935 CHECK_NUMBER (item, 1);
|
|
|
936 charval = XINT (item);
|
|
|
937 size = XSTRING (array)->size;
|
|
|
938 for (index = 0; index < size; index++)
|
|
|
939 p[index] = charval;
|
|
|
940 }
|
|
|
941 else
|
|
|
942 {
|
|
|
943 array = wrong_type_argument (Qarrayp, array);
|
|
|
944 goto retry;
|
|
|
945 }
|
|
|
946 return array;
|
|
|
947 }
|
|
|
948
|
|
|
949 /* ARGSUSED */
|
|
|
950 Lisp_Object
|
|
|
951 nconc2 (s1, s2)
|
|
|
952 Lisp_Object s1, s2;
|
|
|
953 {
|
|
|
954 #ifdef NO_ARG_ARRAY
|
|
|
955 Lisp_Object args[2];
|
|
|
956 args[0] = s1;
|
|
|
957 args[1] = s2;
|
|
|
958 return Fnconc (2, args);
|
|
|
959 #else
|
|
|
960 return Fnconc (2, &s1);
|
|
|
961 #endif /* NO_ARG_ARRAY */
|
|
|
962 }
|
|
|
963
|
|
|
964 DEFUN ("nconc", Fnconc, Snconc, 0, MANY, 0,
|
|
|
965 "Concatenate any number of lists by altering them.\n\
|
|
|
966 Only the last argument is not altered, and need not be a list.")
|
|
|
967 (nargs, args)
|
|
|
968 int nargs;
|
|
|
969 Lisp_Object *args;
|
|
|
970 {
|
|
|
971 register int argnum;
|
|
|
972 register Lisp_Object tail, tem, val;
|
|
|
973
|
|
|
974 val = Qnil;
|
|
|
975
|
|
|
976 for (argnum = 0; argnum < nargs; argnum++)
|
|
|
977 {
|
|
|
978 tem = args[argnum];
|
|
485
|
979 if (NILP (tem)) continue;
|
|
211
|
980
|
|
485
|
981 if (NILP (val))
|
|
211
|
982 val = tem;
|
|
|
983
|
|
|
984 if (argnum + 1 == nargs) break;
|
|
|
985
|
|
|
986 if (!CONSP (tem))
|
|
|
987 tem = wrong_type_argument (Qlistp, tem);
|
|
|
988
|
|
|
989 while (CONSP (tem))
|
|
|
990 {
|
|
|
991 tail = tem;
|
|
|
992 tem = Fcdr (tail);
|
|
|
993 QUIT;
|
|
|
994 }
|
|
|
995
|
|
|
996 tem = args[argnum + 1];
|
|
|
997 Fsetcdr (tail, tem);
|
|
485
|
998 if (NILP (tem))
|
|
211
|
999 args[argnum + 1] = tail;
|
|
|
1000 }
|
|
|
1001
|
|
|
1002 return val;
|
|
|
1003 }
|
|
|
1004
|
|
|
1005 /* This is the guts of all mapping functions.
|
|
|
1006 Apply fn to each element of seq, one by one,
|
|
|
1007 storing the results into elements of vals, a C vector of Lisp_Objects.
|
|
|
1008 leni is the length of vals, which should also be the length of seq. */
|
|
|
1009
|
|
|
1010 static void
|
|
|
1011 mapcar1 (leni, vals, fn, seq)
|
|
|
1012 int leni;
|
|
|
1013 Lisp_Object *vals;
|
|
|
1014 Lisp_Object fn, seq;
|
|
|
1015 {
|
|
|
1016 register Lisp_Object tail;
|
|
|
1017 Lisp_Object dummy;
|
|
|
1018 register int i;
|
|
|
1019 struct gcpro gcpro1, gcpro2, gcpro3;
|
|
|
1020
|
|
|
1021 /* Don't let vals contain any garbage when GC happens. */
|
|
|
1022 for (i = 0; i < leni; i++)
|
|
|
1023 vals[i] = Qnil;
|
|
|
1024
|
|
|
1025 GCPRO3 (dummy, fn, seq);
|
|
|
1026 gcpro1.var = vals;
|
|
|
1027 gcpro1.nvars = leni;
|
|
|
1028 /* We need not explicitly protect `tail' because it is used only on lists, and
|
|
|
1029 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
|
|
|
1030
|
|
|
1031 if (XTYPE (seq) == Lisp_Vector)
|
|
|
1032 {
|
|
|
1033 for (i = 0; i < leni; i++)
|
|
|
1034 {
|
|
|
1035 dummy = XVECTOR (seq)->contents[i];
|
|
|
1036 vals[i] = call1 (fn, dummy);
|
|
|
1037 }
|
|
|
1038 }
|
|
|
1039 else if (XTYPE (seq) == Lisp_String)
|
|
|
1040 {
|
|
|
1041 for (i = 0; i < leni; i++)
|
|
|
1042 {
|
|
|
1043 XFASTINT (dummy) = XSTRING (seq)->data[i];
|
|
|
1044 vals[i] = call1 (fn, dummy);
|
|
|
1045 }
|
|
|
1046 }
|
|
|
1047 else /* Must be a list, since Flength did not get an error */
|
|
|
1048 {
|
|
|
1049 tail = seq;
|
|
|
1050 for (i = 0; i < leni; i++)
|
|
|
1051 {
|
|
|
1052 vals[i] = call1 (fn, Fcar (tail));
|
|
|
1053 tail = Fcdr (tail);
|
|
|
1054 }
|
|
|
1055 }
|
|
|
1056
|
|
|
1057 UNGCPRO;
|
|
|
1058 }
|
|
|
1059
|
|
|
1060 DEFUN ("mapconcat", Fmapconcat, Smapconcat, 3, 3, 0,
|
|
|
1061 "Apply FN to each element of SEQ, and concat the results as strings.\n\
|
|
|
1062 In between each pair of results, stick in SEP.\n\
|
|
5437
|
1063 Thus, \" \" as SEP results in spaces between the values returned by FN.")
|
|
211
|
1064 (fn, seq, sep)
|
|
|
1065 Lisp_Object fn, seq, sep;
|
|
|
1066 {
|
|
|
1067 Lisp_Object len;
|
|
|
1068 register int leni;
|
|
|
1069 int nargs;
|
|
|
1070 register Lisp_Object *args;
|
|
|
1071 register int i;
|
|
|
1072 struct gcpro gcpro1;
|
|
|
1073
|
|
|
1074 len = Flength (seq);
|
|
|
1075 leni = XINT (len);
|
|
|
1076 nargs = leni + leni - 1;
|
|
|
1077 if (nargs < 0) return build_string ("");
|
|
|
1078
|
|
|
1079 args = (Lisp_Object *) alloca (nargs * sizeof (Lisp_Object));
|
|
|
1080
|
|
|
1081 GCPRO1 (sep);
|
|
|
1082 mapcar1 (leni, args, fn, seq);
|
|
|
1083 UNGCPRO;
|
|
|
1084
|
|
|
1085 for (i = leni - 1; i >= 0; i--)
|
|
|
1086 args[i + i] = args[i];
|
|
|
1087
|
|
|
1088 for (i = 1; i < nargs; i += 2)
|
|
|
1089 args[i] = sep;
|
|
|
1090
|
|
|
1091 return Fconcat (nargs, args);
|
|
|
1092 }
|
|
|
1093
|
|
|
1094 DEFUN ("mapcar", Fmapcar, Smapcar, 2, 2, 0,
|
|
|
1095 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
|
|
|
1096 The result is a list just as long as SEQUENCE.\n\
|
|
|
1097 SEQUENCE may be a list, a vector or a string.")
|
|
|
1098 (fn, seq)
|
|
|
1099 Lisp_Object fn, seq;
|
|
|
1100 {
|
|
|
1101 register Lisp_Object len;
|
|
|
1102 register int leni;
|
|
|
1103 register Lisp_Object *args;
|
|
|
1104
|
|
|
1105 len = Flength (seq);
|
|
|
1106 leni = XFASTINT (len);
|
|
|
1107 args = (Lisp_Object *) alloca (leni * sizeof (Lisp_Object));
|
|
|
1108
|
|
|
1109 mapcar1 (leni, args, fn, seq);
|
|
|
1110
|
|
|
1111 return Flist (leni, args);
|
|
|
1112 }
|
|
|
1113
|
|
|
1114 /* Anything that calls this function must protect from GC! */
|
|
|
1115
|
|
|
1116 DEFUN ("y-or-n-p", Fy_or_n_p, Sy_or_n_p, 1, 1, 0,
|
|
|
1117 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
|
|
759
|
1118 Takes one argument, which is the string to display to ask the question.\n\
|
|
|
1119 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.\n\
|
|
211
|
1120 No confirmation of the answer is requested; a single character is enough.\n\
|
|
|
1121 Also accepts Space to mean yes, or Delete to mean no.")
|
|
|
1122 (prompt)
|
|
|
1123 Lisp_Object prompt;
|
|
|
1124 {
|
|
2091
|
1125 register Lisp_Object obj, key, def, answer_string, map;
|
|
|
1126 register int answer;
|
|
211
|
1127 Lisp_Object xprompt;
|
|
|
1128 Lisp_Object args[2];
|
|
|
1129 int ocech = cursor_in_echo_area;
|
|
|
1130 struct gcpro gcpro1, gcpro2;
|
|
|
1131
|
|
2091
|
1132 map = Fsymbol_value (intern ("query-replace-map"));
|
|
|
1133
|
|
211
|
1134 CHECK_STRING (prompt, 0);
|
|
|
1135 xprompt = prompt;
|
|
|
1136 GCPRO2 (prompt, xprompt);
|
|
|
1137
|
|
|
1138 while (1)
|
|
|
1139 {
|
|
6850
|
1140 #ifdef HAVE_X_MENU
|
|
7790
|
1141 if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
|
|
|
1142 && using_x_p ())
|
|
6057
|
1143 {
|
|
|
1144 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
|
1145 redisplay_preserve_echo_area ();
|
|
6057
|
1146 pane = Fcons (Fcons (build_string ("Yes"), Qt),
|
|
|
1147 Fcons (Fcons (build_string ("No"), Qnil),
|
|
|
1148 Qnil));
|
|
6478
|
1149 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
|
1150 obj = Fx_popup_dialog (Qt, menu);
|
|
6057
|
1151 answer = !NILP (obj);
|
|
|
1152 break;
|
|
|
1153 }
|
|
6850
|
1154 #endif
|
|
|
1155 cursor_in_echo_area = 1;
|
|
|
1156 message ("%s(y or n) ", XSTRING (xprompt)->data);
|
|
211
|
1157
|
|
6850
|
1158 obj = read_filtered_event (1, 0, 0);
|
|
|
1159 cursor_in_echo_area = 0;
|
|
|
1160 /* If we need to quit, quit with cursor_in_echo_area = 0. */
|
|
|
1161 QUIT;
|
|
2369
|
1162
|
|
2091
|
1163 key = Fmake_vector (make_number (1), obj);
|
|
|
1164 def = Flookup_key (map, key);
|
|
|
1165 answer_string = Fsingle_key_description (obj);
|
|
211
|
1166
|
|
2091
|
1167 if (EQ (def, intern ("skip")))
|
|
|
1168 {
|
|
|
1169 answer = 0;
|
|
|
1170 break;
|
|
|
1171 }
|
|
|
1172 else if (EQ (def, intern ("act")))
|
|
|
1173 {
|
|
|
1174 answer = 1;
|
|
|
1175 break;
|
|
|
1176 }
|
|
2311
|
1177 else if (EQ (def, intern ("recenter")))
|
|
|
1178 {
|
|
|
1179 Frecenter (Qnil);
|
|
|
1180 xprompt = prompt;
|
|
|
1181 continue;
|
|
|
1182 }
|
|
2091
|
1183 else if (EQ (def, intern ("quit")))
|
|
211
|
1184 Vquit_flag = Qt;
|
|
2091
|
1185
|
|
211
|
1186 QUIT;
|
|
1194
|
1187
|
|
|
1188 /* If we don't clear this, then the next call to read_char will
|
|
|
1189 return quit_char again, and we'll enter an infinite loop. */
|
|
1193
|
1190 Vquit_flag = Qnil;
|
|
211
|
1191
|
|
|
1192 Fding (Qnil);
|
|
|
1193 Fdiscard_input ();
|
|
|
1194 if (EQ (xprompt, prompt))
|
|
|
1195 {
|
|
|
1196 args[0] = build_string ("Please answer y or n. ");
|
|
|
1197 args[1] = prompt;
|
|
|
1198 xprompt = Fconcat (2, args);
|
|
|
1199 }
|
|
|
1200 }
|
|
|
1201 UNGCPRO;
|
|
2171
|
1202
|
|
2525
|
1203 if (! noninteractive)
|
|
|
1204 {
|
|
|
1205 cursor_in_echo_area = -1;
|
|
|
1206 message ("%s(y or n) %c", XSTRING (xprompt)->data, answer ? 'y' : 'n');
|
|
|
1207 cursor_in_echo_area = ocech;
|
|
|
1208 }
|
|
2171
|
1209
|
|
2091
|
1210 return answer ? Qt : Qnil;
|
|
211
|
1211 }
|
|
|
1212
|
|
|
1213 /* This is how C code calls `yes-or-no-p' and allows the user
|
|
|
1214 to redefined it.
|
|
|
1215
|
|
|
1216 Anything that calls this function must protect from GC! */
|
|
|
1217
|
|
|
1218 Lisp_Object
|
|
|
1219 do_yes_or_no_p (prompt)
|
|
|
1220 Lisp_Object prompt;
|
|
|
1221 {
|
|
|
1222 return call1 (intern ("yes-or-no-p"), prompt);
|
|
|
1223 }
|
|
|
1224
|
|
|
1225 /* Anything that calls this function must protect from GC! */
|
|
|
1226
|
|
|
1227 DEFUN ("yes-or-no-p", Fyes_or_no_p, Syes_or_no_p, 1, 1, 0,
|
|
759
|
1228 "Ask user a yes-or-no question. Return t if answer is yes.\n\
|
|
|
1229 Takes one argument, which is the string to display to ask the question.\n\
|
|
|
1230 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.\n\
|
|
|
1231 The user must confirm the answer with RET,\n\
|
|
|
1232 and can edit it until it as been confirmed.")
|
|
211
|
1233 (prompt)
|
|
|
1234 Lisp_Object prompt;
|
|
|
1235 {
|
|
|
1236 register Lisp_Object ans;
|
|
|
1237 Lisp_Object args[2];
|
|
|
1238 struct gcpro gcpro1;
|
|
6057
|
1239 Lisp_Object menu;
|
|
211
|
1240
|
|
|
1241 CHECK_STRING (prompt, 0);
|
|
|
1242
|
|
6850
|
1243 #ifdef HAVE_X_MENU
|
|
7790
|
1244 if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
|
|
|
1245 && using_x_p ())
|
|
6057
|
1246 {
|
|
|
1247 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
|
1248 redisplay_preserve_echo_area ();
|
|
6057
|
1249 pane = Fcons (Fcons (build_string ("Yes"), Qt),
|
|
|
1250 Fcons (Fcons (build_string ("No"), Qnil),
|
|
|
1251 Qnil));
|
|
|
1252 GCPRO1 (pane);
|
|
6478
|
1253 menu = Fcons (prompt, pane);
|
|
6344
|
1254 obj = Fx_popup_dialog (Qt, menu);
|
|
6057
|
1255 UNGCPRO;
|
|
|
1256 return obj;
|
|
|
1257 }
|
|
6850
|
1258 #endif
|
|
6057
|
1259
|
|
211
|
1260 args[0] = prompt;
|
|
|
1261 args[1] = build_string ("(yes or no) ");
|
|
|
1262 prompt = Fconcat (2, args);
|
|
|
1263
|
|
|
1264 GCPRO1 (prompt);
|
|
6057
|
1265
|
|
211
|
1266 while (1)
|
|
|
1267 {
|
|
4456
|
1268 ans = Fdowncase (Fread_from_minibuffer (prompt, Qnil, Qnil, Qnil,
|
|
|
1269 Qyes_or_no_p_history));
|
|
211
|
1270 if (XSTRING (ans)->size == 3 && !strcmp (XSTRING (ans)->data, "yes"))
|
|
|
1271 {
|
|
|
1272 UNGCPRO;
|
|
|
1273 return Qt;
|
|
|
1274 }
|
|
|
1275 if (XSTRING (ans)->size == 2 && !strcmp (XSTRING (ans)->data, "no"))
|
|
|
1276 {
|
|
|
1277 UNGCPRO;
|
|
|
1278 return Qnil;
|
|
|
1279 }
|
|
|
1280
|
|
|
1281 Fding (Qnil);
|
|
|
1282 Fdiscard_input ();
|
|
|
1283 message ("Please answer yes or no.");
|
|
1045
|
1284 Fsleep_for (make_number (2), Qnil);
|
|
211
|
1285 }
|
|
|
1286 }
|
|
|
1287
|
|
|
1288 DEFUN ("load-average", Fload_average, Sload_average, 0, 0, 0,
|
|
|
1289 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
|
|
|
1290 Each of the three load averages is multiplied by 100,\n\
|
|
727
|
1291 then converted to integer.\n\
|
|
|
1292 If the 5-minute or 15-minute load averages are not available, return a\n\
|
|
|
1293 shortened list, containing only those averages which are available.")
|
|
211
|
1294 ()
|
|
|
1295 {
|
|
727
|
1296 double load_ave[3];
|
|
|
1297 int loads = getloadavg (load_ave, 3);
|
|
|
1298 Lisp_Object ret;
|
|
211
|
1299
|
|
727
|
1300 if (loads < 0)
|
|
|
1301 error ("load-average not implemented for this operating system");
|
|
211
|
1302
|
|
727
|
1303 ret = Qnil;
|
|
|
1304 while (loads > 0)
|
|
|
1305 ret = Fcons (make_number ((int) (load_ave[--loads] * 100.0)), ret);
|
|
211
|
1306
|
|
727
|
1307 return ret;
|
|
211
|
1308 }
|
|
|
1309
|
|
|
1310 Lisp_Object Vfeatures;
|
|
|
1311
|
|
|
1312 DEFUN ("featurep", Ffeaturep, Sfeaturep, 1, 1, 0,
|
|
|
1313 "Returns t if FEATURE is present in this Emacs.\n\
|
|
|
1314 Use this to conditionalize execution of lisp code based on the presence or\n\
|
|
|
1315 absence of emacs or environment extensions.\n\
|
|
|
1316 Use `provide' to declare that a feature is available.\n\
|
|
|
1317 This function looks at the value of the variable `features'.")
|
|
|
1318 (feature)
|
|
|
1319 Lisp_Object feature;
|
|
|
1320 {
|
|
|
1321 register Lisp_Object tem;
|
|
|
1322 CHECK_SYMBOL (feature, 0);
|
|
|
1323 tem = Fmemq (feature, Vfeatures);
|
|
485
|
1324 return (NILP (tem)) ? Qnil : Qt;
|
|
211
|
1325 }
|
|
|
1326
|
|
|
1327 DEFUN ("provide", Fprovide, Sprovide, 1, 1, 0,
|
|
|
1328 "Announce that FEATURE is a feature of the current Emacs.")
|
|
|
1329 (feature)
|
|
|
1330 Lisp_Object feature;
|
|
|
1331 {
|
|
|
1332 register Lisp_Object tem;
|
|
|
1333 CHECK_SYMBOL (feature, 0);
|
|
485
|
1334 if (!NILP (Vautoload_queue))
|
|
211
|
1335 Vautoload_queue = Fcons (Fcons (Vfeatures, Qnil), Vautoload_queue);
|
|
|
1336 tem = Fmemq (feature, Vfeatures);
|
|
485
|
1337 if (NILP (tem))
|
|
211
|
1338 Vfeatures = Fcons (feature, Vfeatures);
|
|
2546
|
1339 LOADHIST_ATTACH (Fcons (Qprovide, feature));
|
|
211
|
1340 return feature;
|
|
|
1341 }
|
|
|
1342
|
|
|
1343 DEFUN ("require", Frequire, Srequire, 1, 2, 0,
|
|
|
1344 "If feature FEATURE is not loaded, load it from FILENAME.\n\
|
|
|
1345 If FEATURE is not a member of the list `features', then the feature\n\
|
|
|
1346 is not loaded; so load the file FILENAME.\n\
|
|
|
1347 If FILENAME is omitted, the printname of FEATURE is used as the file name.")
|
|
|
1348 (feature, file_name)
|
|
|
1349 Lisp_Object feature, file_name;
|
|
|
1350 {
|
|
|
1351 register Lisp_Object tem;
|
|
|
1352 CHECK_SYMBOL (feature, 0);
|
|
|
1353 tem = Fmemq (feature, Vfeatures);
|
|
2546
|
1354 LOADHIST_ATTACH (Fcons (Qrequire, feature));
|
|
485
|
1355 if (NILP (tem))
|
|
211
|
1356 {
|
|
|
1357 int count = specpdl_ptr - specpdl;
|
|
|
1358
|
|
|
1359 /* Value saved here is to be restored into Vautoload_queue */
|
|
|
1360 record_unwind_protect (un_autoload, Vautoload_queue);
|
|
|
1361 Vautoload_queue = Qt;
|
|
|
1362
|
|
485
|
1363 Fload (NILP (file_name) ? Fsymbol_name (feature) : file_name,
|
|
211
|
1364 Qnil, Qt, Qnil);
|
|
|
1365
|
|
|
1366 tem = Fmemq (feature, Vfeatures);
|
|
485
|
1367 if (NILP (tem))
|
|
211
|
1368 error ("Required feature %s was not provided",
|
|
|
1369 XSYMBOL (feature)->name->data );
|
|
|
1370
|
|
|
1371 /* Once loading finishes, don't undo it. */
|
|
|
1372 Vautoload_queue = Qt;
|
|
|
1373 feature = unbind_to (count, feature);
|
|
|
1374 }
|
|
|
1375 return feature;
|
|
|
1376 }
|
|
|
1377
|
|
|
1378 syms_of_fns ()
|
|
|
1379 {
|
|
|
1380 Qstring_lessp = intern ("string-lessp");
|
|
|
1381 staticpro (&Qstring_lessp);
|
|
2546
|
1382 Qprovide = intern ("provide");
|
|
|
1383 staticpro (&Qprovide);
|
|
|
1384 Qrequire = intern ("require");
|
|
|
1385 staticpro (&Qrequire);
|
|
4456
|
1386 Qyes_or_no_p_history = intern ("yes-or-no-p-history");
|
|
|
1387 staticpro (&Qyes_or_no_p_history);
|
|
211
|
1388
|
|
|
1389 DEFVAR_LISP ("features", &Vfeatures,
|
|
|
1390 "A list of symbols which are the features of the executing emacs.\n\
|
|
|
1391 Used by `featurep' and `require', and altered by `provide'.");
|
|
|
1392 Vfeatures = Qnil;
|
|
|
1393
|
|
|
1394 defsubr (&Sidentity);
|
|
|
1395 defsubr (&Srandom);
|
|
|
1396 defsubr (&Slength);
|
|
|
1397 defsubr (&Sstring_equal);
|
|
|
1398 defsubr (&Sstring_lessp);
|
|
|
1399 defsubr (&Sappend);
|
|
|
1400 defsubr (&Sconcat);
|
|
|
1401 defsubr (&Svconcat);
|
|
|
1402 defsubr (&Scopy_sequence);
|
|
|
1403 defsubr (&Scopy_alist);
|
|
|
1404 defsubr (&Ssubstring);
|
|
|
1405 defsubr (&Snthcdr);
|
|
|
1406 defsubr (&Snth);
|
|
|
1407 defsubr (&Selt);
|
|
|
1408 defsubr (&Smember);
|
|
|
1409 defsubr (&Smemq);
|
|
|
1410 defsubr (&Sassq);
|
|
|
1411 defsubr (&Sassoc);
|
|
|
1412 defsubr (&Srassq);
|
|
|
1413 defsubr (&Sdelq);
|
|
414
|
1414 defsubr (&Sdelete);
|
|
211
|
1415 defsubr (&Snreverse);
|
|
|
1416 defsubr (&Sreverse);
|
|
|
1417 defsubr (&Ssort);
|
|
|
1418 defsubr (&Sget);
|
|
|
1419 defsubr (&Sput);
|
|
|
1420 defsubr (&Sequal);
|
|
|
1421 defsubr (&Sfillarray);
|
|
|
1422 defsubr (&Snconc);
|
|
|
1423 defsubr (&Smapcar);
|
|
|
1424 defsubr (&Smapconcat);
|
|
|
1425 defsubr (&Sy_or_n_p);
|
|
|
1426 defsubr (&Syes_or_no_p);
|
|
|
1427 defsubr (&Sload_average);
|
|
|
1428 defsubr (&Sfeaturep);
|
|
|
1429 defsubr (&Srequire);
|
|
|
1430 defsubr (&Sprovide);
|
|
|
1431 }
|
