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