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