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