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