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