1 /* Random utility Lisp functions.
2 Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
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)
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.
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. */
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. */
31 #define XBSD4_3 /* XBSD4_3 says BSD4_3 is supposed to be defined. */
33 #include <sys/param.h>
34 /* Now if BSD or BSD4_3 was defined and is no longer,
48 #else /* NLIST_STRUCT */
50 #endif /* NLIST_STRUCT */
52 #endif /* LOAD_AVE_TYPE */
54 /* Note on some machines this defines `vector' as a typedef,
55 so make sure we don't use that name in this file. */
71 Lisp_Object Qstring_lessp
;
73 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
74 "Return the argument unchanged.")
81 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
82 "Return a pseudo-random number.\n\
83 On most systems all integers representable in Lisp are equally likely.\n\
84 This is 24 bits' worth.\n\
85 With argument N, return random number in interval [0,N).\n\
86 With argument t, set the random number seed from the current time and pid.")
91 extern long random ();
96 srandom (getpid () + time (0));
98 if (XTYPE (arg
) == Lisp_Int
&& XINT (arg
) != 0)
100 /* Try to take our random number from the higher bits of VAL,
101 not the lower, since (says Gentzel) the low bits of `random'
102 are less random than the higher ones. */
103 val
&= 0xfffffff; /* Ensure positive. */
105 if (XINT (arg
) < 10000)
109 return make_number (val
);
112 /* Random data-structure functions */
114 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
115 "Return the length of vector, list or string SEQUENCE.\n\
116 A byte-code function object is also allowed.")
118 register Lisp_Object obj
;
120 register Lisp_Object tail
, val
;
124 if (XTYPE (obj
) == Lisp_Vector
|| XTYPE (obj
) == Lisp_String
125 || XTYPE (obj
) == Lisp_Compiled
)
126 return Farray_length (obj
);
127 else if (CONSP (obj
))
129 for (i
= 0, tail
= obj
; !NULL(tail
); i
++)
145 obj
= wrong_type_argument (Qsequencep
, obj
);
150 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
151 "T if two strings have identical contents.\n\
152 Case is significant.\n\
153 Symbols are also allowed; their print names are used instead.")
155 register Lisp_Object s1
, s2
;
157 if (XTYPE (s1
) == Lisp_Symbol
)
158 XSETSTRING (s1
, XSYMBOL (s1
)->name
), XSETTYPE (s1
, Lisp_String
);
159 if (XTYPE (s2
) == Lisp_Symbol
)
160 XSETSTRING (s2
, XSYMBOL (s2
)->name
), XSETTYPE (s2
, Lisp_String
);
161 CHECK_STRING (s1
, 0);
162 CHECK_STRING (s2
, 1);
164 if (XSTRING (s1
)->size
!= XSTRING (s2
)->size
||
165 bcmp (XSTRING (s1
)->data
, XSTRING (s2
)->data
, XSTRING (s1
)->size
))
170 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
171 "T if first arg string is less than second in lexicographic order.\n\
172 Case is significant.\n\
173 Symbols are also allowed; their print names are used instead.")
175 register Lisp_Object s1
, s2
;
178 register unsigned char *p1
, *p2
;
181 if (XTYPE (s1
) == Lisp_Symbol
)
182 XSETSTRING (s1
, XSYMBOL (s1
)->name
), XSETTYPE (s1
, Lisp_String
);
183 if (XTYPE (s2
) == Lisp_Symbol
)
184 XSETSTRING (s2
, XSYMBOL (s2
)->name
), XSETTYPE (s2
, Lisp_String
);
185 CHECK_STRING (s1
, 0);
186 CHECK_STRING (s2
, 1);
188 p1
= XSTRING (s1
)->data
;
189 p2
= XSTRING (s2
)->data
;
190 end
= XSTRING (s1
)->size
;
191 if (end
> XSTRING (s2
)->size
)
192 end
= XSTRING (s2
)->size
;
194 for (i
= 0; i
< end
; i
++)
197 return p1
[i
] < p2
[i
] ? Qt
: Qnil
;
199 return i
< XSTRING (s2
)->size
? Qt
: Qnil
;
202 static Lisp_Object
concat ();
213 return concat (2, args
, Lisp_String
, 0);
215 return concat (2, &s1
, Lisp_String
, 0);
216 #endif /* NO_ARG_ARRAY */
219 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
220 "Concatenate all the arguments and make the result a list.\n\
221 The result is a list whose elements are the elements of all the arguments.\n\
222 Each argument may be a list, vector or string.\n\
223 The last argument is not copied if it is a list.")
228 return concat (nargs
, args
, Lisp_Cons
, 1);
231 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
232 "Concatenate all the arguments and make the result a string.\n\
233 The result is a string whose elements are the elements of all the arguments.\n\
234 Each argument may be a string, a list of numbers, or a vector of numbers.")
239 return concat (nargs
, args
, Lisp_String
, 0);
242 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
243 "Concatenate all the arguments and make the result a vector.\n\
244 The result is a vector whose elements are the elements of all the arguments.\n\
245 Each argument may be a list, vector or string.")
250 return concat (nargs
, args
, Lisp_Vector
, 0);
253 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
254 "Return a copy of a list, vector or string.\n\
255 The elements of a list or vector are not copied; they are shared\n\
260 if (NULL (arg
)) return arg
;
261 if (!CONSP (arg
) && XTYPE (arg
) != Lisp_Vector
&& XTYPE (arg
) != Lisp_String
)
262 arg
= wrong_type_argument (Qsequencep
, arg
);
263 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
267 concat (nargs
, args
, target_type
, last_special
)
270 enum Lisp_Type target_type
;
275 register Lisp_Object tail
;
276 register Lisp_Object
this;
280 Lisp_Object last_tail
;
283 /* In append, the last arg isn't treated like the others */
284 if (last_special
&& nargs
> 0)
287 last_tail
= args
[nargs
];
292 for (argnum
= 0; argnum
< nargs
; argnum
++)
295 if (!(CONSP (this) || NULL (this)
296 || XTYPE (this) == Lisp_Vector
|| XTYPE (this) == Lisp_String
297 || XTYPE (this) == Lisp_Compiled
))
299 if (XTYPE (this) == Lisp_Int
)
300 args
[argnum
] = Fint_to_string (this);
302 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
306 for (argnum
= 0, leni
= 0; argnum
< nargs
; argnum
++)
309 len
= Flength (this);
310 leni
+= XFASTINT (len
);
313 XFASTINT (len
) = leni
;
315 if (target_type
== Lisp_Cons
)
316 val
= Fmake_list (len
, Qnil
);
317 else if (target_type
== Lisp_Vector
)
318 val
= Fmake_vector (len
, Qnil
);
320 val
= Fmake_string (len
, len
);
322 /* In append, if all but last arg are nil, return last arg */
323 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
327 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
333 for (argnum
= 0; argnum
< nargs
; argnum
++)
337 register int thisindex
= 0;
341 thislen
= Flength (this), thisleni
= XINT (thislen
);
345 register Lisp_Object elt
;
347 /* Fetch next element of `this' arg into `elt', or break if `this' is exhausted. */
348 if (NULL (this)) break;
350 elt
= Fcar (this), this = Fcdr (this);
353 if (thisindex
>= thisleni
) break;
354 if (XTYPE (this) == Lisp_String
)
355 XFASTINT (elt
) = XSTRING (this)->data
[thisindex
++];
357 elt
= XVECTOR (this)->contents
[thisindex
++];
360 /* Store into result */
363 XCONS (tail
)->car
= elt
;
365 tail
= XCONS (tail
)->cdr
;
367 else if (XTYPE (val
) == Lisp_Vector
)
368 XVECTOR (val
)->contents
[toindex
++] = elt
;
371 while (XTYPE (elt
) != Lisp_Int
)
372 elt
= wrong_type_argument (Qintegerp
, elt
);
374 #ifdef MASSC_REGISTER_BUG
375 /* Even removing all "register"s doesn't disable this bug!
376 Nothing simpler than this seems to work. */
377 unsigned char *p
= & XSTRING (val
)->data
[toindex
++];
380 XSTRING (val
)->data
[toindex
++] = XINT (elt
);
387 XCONS (prev
)->cdr
= last_tail
;
392 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
393 "Return a copy of ALIST.\n\
394 This is an alist which represents the same mapping from objects to objects,\n\
395 but does not share the alist structure with ALIST.\n\
396 The objects mapped (cars and cdrs of elements of the alist)\n\
397 are shared, however.\n\
398 Elements of ALIST that are not conses are also shared.")
402 register Lisp_Object tem
;
404 CHECK_LIST (alist
, 0);
407 alist
= concat (1, &alist
, Lisp_Cons
, 0);
408 for (tem
= alist
; CONSP (tem
); tem
= XCONS (tem
)->cdr
)
410 register Lisp_Object car
;
411 car
= XCONS (tem
)->car
;
414 XCONS (tem
)->car
= Fcons (XCONS (car
)->car
, XCONS (car
)->cdr
);
419 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
420 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
421 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
422 If FROM or TO is negative, it counts from the end.")
425 register Lisp_Object from
, to
;
427 CHECK_STRING (string
, 0);
428 CHECK_NUMBER (from
, 1);
430 to
= Flength (string
);
432 CHECK_NUMBER (to
, 2);
435 XSETINT (from
, XINT (from
) + XSTRING (string
)->size
);
437 XSETINT (to
, XINT (to
) + XSTRING (string
)->size
);
438 if (!(0 <= XINT (from
) && XINT (from
) <= XINT (to
)
439 && XINT (to
) <= XSTRING (string
)->size
))
440 args_out_of_range_3 (string
, from
, to
);
442 return make_string (XSTRING (string
)->data
+ XINT (from
),
443 XINT (to
) - XINT (from
));
446 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
447 "Take cdr N times on LIST, returns the result.")
450 register Lisp_Object list
;
455 for (i
= 0; i
< num
&& !NULL (list
); i
++)
463 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
464 "Return the Nth element of LIST.\n\
465 N counts from zero. If LIST is not that long, nil is returned.")
469 return Fcar (Fnthcdr (n
, list
));
472 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
473 "Return element of SEQUENCE at index N.")
475 register Lisp_Object seq
, n
;
480 if (XTYPE (seq
) == Lisp_Cons
|| NULL (seq
))
481 return Fcar (Fnthcdr (n
, seq
));
482 else if (XTYPE (seq
) == Lisp_String
||
483 XTYPE (seq
) == Lisp_Vector
)
484 return Faref (seq
, n
);
486 seq
= wrong_type_argument (Qsequencep
, seq
);
490 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
491 "Return non-nil if ELT is an element of LIST. Comparison done with EQUAL.\n\
492 The value is actually the tail of LIST whose car is ELT.")
494 register Lisp_Object elt
;
497 register Lisp_Object tail
;
498 for (tail
= list
; !NULL (tail
); tail
= Fcdr (tail
))
500 register Lisp_Object tem
;
502 if (! NULL (Fequal (elt
, tem
)))
509 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
510 "Return non-nil if ELT is an element of LIST. Comparison done with EQ.\n\
511 The value is actually the tail of LIST whose car is ELT.")
513 register Lisp_Object elt
;
516 register Lisp_Object tail
;
517 for (tail
= list
; !NULL (tail
); tail
= Fcdr (tail
))
519 register Lisp_Object tem
;
521 if (EQ (elt
, tem
)) return tail
;
527 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
528 "Return non-nil if ELT is `eq' to the car of an element of LIST.\n\
529 The value is actually the element of LIST whose car is ELT.\n\
530 Elements of LIST that are not conses are ignored.")
532 register Lisp_Object key
;
535 register Lisp_Object tail
;
536 for (tail
= list
; !NULL (tail
); tail
= Fcdr (tail
))
538 register Lisp_Object elt
, tem
;
540 if (!CONSP (elt
)) continue;
542 if (EQ (key
, tem
)) return elt
;
548 /* Like Fassq but never report an error and do not allow quits.
549 Use only on lists known never to be circular. */
552 assq_no_quit (key
, list
)
553 register Lisp_Object key
;
556 register Lisp_Object tail
;
557 for (tail
= list
; CONSP (tail
); tail
= Fcdr (tail
))
559 register Lisp_Object elt
, tem
;
561 if (!CONSP (elt
)) continue;
563 if (EQ (key
, tem
)) return elt
;
568 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
569 "Return non-nil if ELT is `equal' to the car of an element of LIST.\n\
570 The value is actually the element of LIST whose car is ELT.")
572 register Lisp_Object key
;
575 register Lisp_Object tail
;
576 for (tail
= list
; !NULL (tail
); tail
= Fcdr (tail
))
578 register Lisp_Object elt
, tem
;
580 if (!CONSP (elt
)) continue;
581 tem
= Fequal (Fcar (elt
), key
);
582 if (!NULL (tem
)) return elt
;
588 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
589 "Return non-nil if ELT is `eq' to the cdr of an element of LIST.\n\
590 The value is actually the element of LIST whose cdr is ELT.")
592 register Lisp_Object key
;
595 register Lisp_Object tail
;
596 for (tail
= list
; !NULL (tail
); tail
= Fcdr (tail
))
598 register Lisp_Object elt
, tem
;
600 if (!CONSP (elt
)) continue;
602 if (EQ (key
, tem
)) return elt
;
608 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
609 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
610 The modified LIST is returned. Comparison is done with `eq'.\n\
611 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
612 therefore, write `(setq foo (delq element foo))'\n\
613 to be sure of changing the value of `foo'.")
615 register Lisp_Object elt
;
618 register Lisp_Object tail
, prev
;
619 register Lisp_Object tem
;
631 Fsetcdr (prev
, Fcdr (tail
));
641 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
642 "Reverse LIST by modifying cdr pointers.\n\
643 Returns the beginning of the reversed list.")
647 register Lisp_Object prev
, tail
, next
;
649 if (NULL (list
)) return list
;
656 Fsetcdr (tail
, prev
);
663 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
664 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
665 See also the function `nreverse', which is used more often.")
670 register Lisp_Object
*vec
;
671 register Lisp_Object tail
;
674 length
= Flength (list
);
675 vec
= (Lisp_Object
*) alloca (XINT (length
) * sizeof (Lisp_Object
));
676 for (i
= XINT (length
) - 1, tail
= list
; i
>= 0; i
--, tail
= Fcdr (tail
))
677 vec
[i
] = Fcar (tail
);
679 return Flist (XINT (length
), vec
);
682 Lisp_Object
merge ();
684 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
685 "Sort LIST, stably, comparing elements using PREDICATE.\n\
686 Returns the sorted list. LIST is modified by side effects.\n\
687 PREDICATE is called with two elements of LIST, and should return T\n\
688 if the first element is \"less\" than the second.")
690 Lisp_Object list
, pred
;
692 Lisp_Object front
, back
;
693 register Lisp_Object len
, tem
;
694 struct gcpro gcpro1
, gcpro2
;
698 len
= Flength (list
);
703 XSETINT (len
, (length
/ 2) - 1);
704 tem
= Fnthcdr (len
, list
);
708 GCPRO2 (front
, back
);
709 front
= Fsort (front
, pred
);
710 back
= Fsort (back
, pred
);
712 return merge (front
, back
, pred
);
716 merge (org_l1
, org_l2
, pred
)
717 Lisp_Object org_l1
, org_l2
;
721 register Lisp_Object tail
;
723 register Lisp_Object l1
, l2
;
724 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
731 /* It is sufficient to protect org_l1 and org_l2.
732 When l1 and l2 are updated, we copy the new values
733 back into the org_ vars. */
734 GCPRO4 (org_l1
, org_l2
, pred
, value
);
754 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
775 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
776 "Return the value of SYMBOL's PROPNAME property.\n\
777 This is the last VALUE stored with `(put SYMBOL PROPNAME VALUE)'.")
780 register Lisp_Object prop
;
782 register Lisp_Object tail
;
783 for (tail
= Fsymbol_plist (sym
); !NULL (tail
); tail
= Fcdr (Fcdr (tail
)))
785 register Lisp_Object tem
;
788 return Fcar (Fcdr (tail
));
793 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
794 "Store SYMBOL's PROPNAME property with value VALUE.\n\
795 It can be retrieved with `(get SYMBOL PROPNAME)'.")
798 register Lisp_Object prop
;
801 register Lisp_Object tail
, prev
;
804 for (tail
= Fsymbol_plist (sym
); !NULL (tail
); tail
= Fcdr (Fcdr (tail
)))
806 register Lisp_Object tem
;
809 return Fsetcar (Fcdr (tail
), val
);
812 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
814 Fsetplist (sym
, newcell
);
816 Fsetcdr (Fcdr (prev
), newcell
);
820 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
821 "T if two Lisp objects have similar structure and contents.\n\
822 They must have the same data type.\n\
823 Conses are compared by comparing the cars and the cdrs.\n\
824 Vectors and strings are compared element by element.\n\
825 Numbers are compared by value. Symbols must match exactly.")
827 register Lisp_Object o1
, o2
;
831 if (XTYPE (o1
) != XTYPE (o2
)) return Qnil
;
832 if (XINT (o1
) == XINT (o2
)) return Qt
;
833 if (XTYPE (o1
) == Lisp_Cons
)
836 v1
= Fequal (Fcar (o1
), Fcar (o2
));
839 o1
= Fcdr (o1
), o2
= Fcdr (o2
);
842 if (XTYPE (o1
) == Lisp_Marker
)
844 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
845 && XMARKER (o1
)->bufpos
== XMARKER (o2
)->bufpos
)
848 if (XTYPE (o1
) == Lisp_Vector
)
851 if (XVECTOR (o1
)->size
!= XVECTOR (o2
)->size
)
853 for (index
= 0; index
< XVECTOR (o1
)->size
; index
++)
855 Lisp_Object v
, v1
, v2
;
856 v1
= XVECTOR (o1
)->contents
[index
];
857 v2
= XVECTOR (o2
)->contents
[index
];
859 if (NULL (v
)) return v
;
863 if (XTYPE (o1
) == Lisp_String
)
865 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
867 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
, XSTRING (o1
)->size
))
874 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
875 "Store each element of ARRAY with ITEM. ARRAY is a vector or string.")
877 Lisp_Object array
, item
;
879 register int size
, index
, charval
;
881 if (XTYPE (array
) == Lisp_Vector
)
883 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
884 size
= XVECTOR (array
)->size
;
885 for (index
= 0; index
< size
; index
++)
888 else if (XTYPE (array
) == Lisp_String
)
890 register unsigned char *p
= XSTRING (array
)->data
;
891 CHECK_NUMBER (item
, 1);
892 charval
= XINT (item
);
893 size
= XSTRING (array
)->size
;
894 for (index
= 0; index
< size
; index
++)
899 array
= wrong_type_argument (Qarrayp
, array
);
914 return Fnconc (2, args
);
916 return Fnconc (2, &s1
);
917 #endif /* NO_ARG_ARRAY */
920 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
921 "Concatenate any number of lists by altering them.\n\
922 Only the last argument is not altered, and need not be a list.")
928 register Lisp_Object tail
, tem
, val
;
932 for (argnum
= 0; argnum
< nargs
; argnum
++)
935 if (NULL (tem
)) continue;
940 if (argnum
+ 1 == nargs
) break;
943 tem
= wrong_type_argument (Qlistp
, tem
);
952 tem
= args
[argnum
+ 1];
955 args
[argnum
+ 1] = tail
;
961 /* This is the guts of all mapping functions.
962 Apply fn to each element of seq, one by one,
963 storing the results into elements of vals, a C vector of Lisp_Objects.
964 leni is the length of vals, which should also be the length of seq. */
967 mapcar1 (leni
, vals
, fn
, seq
)
972 register Lisp_Object tail
;
975 struct gcpro gcpro1
, gcpro2
, gcpro3
;
977 /* Don't let vals contain any garbage when GC happens. */
978 for (i
= 0; i
< leni
; i
++)
981 GCPRO3 (dummy
, fn
, seq
);
984 /* We need not explicitly protect `tail' because it is used only on lists, and
985 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
987 if (XTYPE (seq
) == Lisp_Vector
)
989 for (i
= 0; i
< leni
; i
++)
991 dummy
= XVECTOR (seq
)->contents
[i
];
992 vals
[i
] = call1 (fn
, dummy
);
995 else if (XTYPE (seq
) == Lisp_String
)
997 for (i
= 0; i
< leni
; i
++)
999 XFASTINT (dummy
) = XSTRING (seq
)->data
[i
];
1000 vals
[i
] = call1 (fn
, dummy
);
1003 else /* Must be a list, since Flength did not get an error */
1006 for (i
= 0; i
< leni
; i
++)
1008 vals
[i
] = call1 (fn
, Fcar (tail
));
1016 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
1017 "Apply FN to each element of SEQ, and concat the results as strings.\n\
1018 In between each pair of results, stick in SEP.\n\
1019 Thus, \" \" as SEP results in spaces between the values return by FN.")
1021 Lisp_Object fn
, seq
, sep
;
1026 register Lisp_Object
*args
;
1028 struct gcpro gcpro1
;
1030 len
= Flength (seq
);
1032 nargs
= leni
+ leni
- 1;
1033 if (nargs
< 0) return build_string ("");
1035 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
1038 mapcar1 (leni
, args
, fn
, seq
);
1041 for (i
= leni
- 1; i
>= 0; i
--)
1042 args
[i
+ i
] = args
[i
];
1044 for (i
= 1; i
< nargs
; i
+= 2)
1047 return Fconcat (nargs
, args
);
1050 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
1051 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
1052 The result is a list just as long as SEQUENCE.\n\
1053 SEQUENCE may be a list, a vector or a string.")
1055 Lisp_Object fn
, seq
;
1057 register Lisp_Object len
;
1059 register Lisp_Object
*args
;
1061 len
= Flength (seq
);
1062 leni
= XFASTINT (len
);
1063 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
1065 mapcar1 (leni
, args
, fn
, seq
);
1067 return Flist (leni
, args
);
1070 /* Anything that calls this function must protect from GC! */
1072 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
1073 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
1074 No confirmation of the answer is requested; a single character is enough.\n\
1075 Also accepts Space to mean yes, or Delete to mean no.")
1079 register Lisp_Object obj
;
1081 Lisp_Object xprompt
;
1082 Lisp_Object args
[2];
1083 int ocech
= cursor_in_echo_area
;
1084 struct gcpro gcpro1
, gcpro2
;
1086 CHECK_STRING (prompt
, 0);
1088 GCPRO2 (prompt
, xprompt
);
1092 message ("%s(y or n) ", XSTRING (xprompt
)->data
);
1093 cursor_in_echo_area
= 1;
1095 obj
= read_char (0);
1096 if (XTYPE (obj
) == Lisp_Int
)
1101 cursor_in_echo_area
= -1;
1102 message ("%s(y or n) %c", XSTRING (xprompt
)->data
, ans
);
1103 cursor_in_echo_area
= ocech
;
1104 /* Accept a C-g or C-] (abort-recursive-edit) as quit requests. */
1105 if (ans
== 7 || ans
== '\035')
1109 ans
= DOWNCASE (ans
);
1110 if (ans
== 'y' || ans
== ' ')
1111 { ans
= 'y'; break; }
1112 if (ans
== 'n' || ans
== 127)
1117 if (EQ (xprompt
, prompt
))
1119 args
[0] = build_string ("Please answer y or n. ");
1121 xprompt
= Fconcat (2, args
);
1125 return (ans
== 'y' ? Qt
: Qnil
);
1128 /* This is how C code calls `yes-or-no-p' and allows the user
1131 Anything that calls this function must protect from GC! */
1134 do_yes_or_no_p (prompt
)
1137 return call1 (intern ("yes-or-no-p"), prompt
);
1140 /* Anything that calls this function must protect from GC! */
1142 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
1143 "Ask user a yes or no question. Return t if answer is yes.\n\
1144 The user must confirm the answer with a newline,\n\
1145 and can rub it out if not confirmed.")
1149 register Lisp_Object ans
;
1150 Lisp_Object args
[2];
1151 struct gcpro gcpro1
;
1153 CHECK_STRING (prompt
, 0);
1156 args
[1] = build_string ("(yes or no) ");
1157 prompt
= Fconcat (2, args
);
1162 ans
= Fdowncase (read_minibuf (Vminibuffer_local_map
,
1163 Qnil
, prompt
, Qnil
, 0));
1164 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
1169 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
1177 message ("Please answer yes or no.");
1178 Fsleep_for (make_number (2));
1183 /* Avoid static vars inside a function since in HPUX they dump as pure. */
1184 static int ldav_initialized
;
1185 static int ldav_channel
;
1186 #ifdef LOAD_AVE_TYPE
1188 static struct nlist ldav_nl
[2];
1190 #endif /* LOAD_AVE_TYPE */
1192 #define channel ldav_channel
1193 #define initialized ldav_initialized
1196 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 0, 0,
1197 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
1198 Each of the three load averages is multiplied by 100,\n\
1199 then converted to integer.")
1202 #ifndef LOAD_AVE_TYPE
1203 error ("load-average not implemented for this operating system");
1205 #else /* LOAD_AVE_TYPE defined */
1207 LOAD_AVE_TYPE load_ave
[3];
1211 #include <descrip.h>
1213 #include <vms/iodef.h>
1214 struct {int dsc$w_length
; char *dsc$a_pointer
;} descriptor
;
1218 /* If this fails for any reason, we can return (0 0 0) */
1219 load_ave
[0] = 0.0; load_ave
[1] = 0.0; load_ave
[2] = 0.0;
1223 * VMS specific code -- read from the Load Ave driver
1227 * Ensure that there is a channel open to the load ave device
1229 if (initialized
== 0)
1231 /* Attempt to open the channel */
1233 descriptor
.size
= 18;
1234 descriptor
.ptr
= "$$VMS_LOAD_AVERAGE";
1236 $
DESCRIPTOR(descriptor
, "LAV0:");
1238 if (sys$
assign (&descriptor
, &channel
, 0, 0) & 1)
1242 * Read the load average vector
1246 if (!(sys$
qiow (0, channel
, IO$_READVBLK
, 0, 0, 0,
1247 load_ave
, 12, 0, 0, 0, 0)
1250 sys$
dassgn (channel
);
1256 * 4.2BSD UNIX-specific code -- read _avenrun from /dev/kmem
1260 * Make sure we have the address of _avenrun
1262 if (nl
[0].n_value
== 0)
1265 * Get the address of _avenrun
1267 #ifndef NLIST_STRUCT
1268 strcpy (nl
[0].n_name
, LDAV_SYMBOL
);
1270 #else /* NLIST_STRUCT */
1272 nl
[0].n_un
.n_name
= LDAV_SYMBOL
;
1273 nl
[1].n_un
.n_name
= 0;
1274 #else /* not convex */
1275 nl
[0].n_name
= LDAV_SYMBOL
;
1277 #endif /* not convex */
1278 #endif /* NLIST_STRUCT */
1280 nlist (KERNEL_FILE
, nl
);
1282 #ifdef FIXUP_KERNEL_SYMBOL_ADDR
1283 FIXUP_KERNEL_SYMBOL_ADDR (nl
);
1284 #endif /* FIXUP_KERNEL_SYMBOL_ADDR */
1287 * Make sure we have /dev/kmem open
1289 if (initialized
== 0)
1294 channel
= open ("/dev/kmem", 0);
1295 if (channel
>= 0) initialized
= 1;
1298 * If we can, get the load ave values
1300 if ((nl
[0].n_value
!= 0) && (initialized
!= 0))
1303 * Seek to the correct address
1305 lseek (channel
, (long) nl
[0].n_value
, 0);
1306 if (read (channel
, load_ave
, sizeof load_ave
)
1307 != sizeof(load_ave
))
1313 #endif /* not VMS */
1316 * Return the list of load average values
1318 return Fcons (make_number (LOAD_AVE_CVT (load_ave
[0])),
1319 Fcons (make_number (LOAD_AVE_CVT (load_ave
[1])),
1320 Fcons (make_number (LOAD_AVE_CVT (load_ave
[2])),
1322 #endif /* LOAD_AVE_TYPE */
1329 Lisp_Object Vfeatures
;
1331 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
1332 "Returns t if FEATURE is present in this Emacs.\n\
1333 Use this to conditionalize execution of lisp code based on the presence or\n\
1334 absence of emacs or environment extensions.\n\
1335 Use `provide' to declare that a feature is available.\n\
1336 This function looks at the value of the variable `features'.")
1338 Lisp_Object feature
;
1340 register Lisp_Object tem
;
1341 CHECK_SYMBOL (feature
, 0);
1342 tem
= Fmemq (feature
, Vfeatures
);
1343 return (NULL (tem
)) ? Qnil
: Qt
;
1346 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
1347 "Announce that FEATURE is a feature of the current Emacs.")
1349 Lisp_Object feature
;
1351 register Lisp_Object tem
;
1352 CHECK_SYMBOL (feature
, 0);
1353 if (!NULL (Vautoload_queue
))
1354 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
1355 tem
= Fmemq (feature
, Vfeatures
);
1357 Vfeatures
= Fcons (feature
, Vfeatures
);
1361 DEFUN ("require", Frequire
, Srequire
, 1, 2, 0,
1362 "If feature FEATURE is not loaded, load it from FILENAME.\n\
1363 If FEATURE is not a member of the list `features', then the feature\n\
1364 is not loaded; so load the file FILENAME.\n\
1365 If FILENAME is omitted, the printname of FEATURE is used as the file name.")
1366 (feature
, file_name
)
1367 Lisp_Object feature
, file_name
;
1369 register Lisp_Object tem
;
1370 CHECK_SYMBOL (feature
, 0);
1371 tem
= Fmemq (feature
, Vfeatures
);
1374 int count
= specpdl_ptr
- specpdl
;
1376 /* Value saved here is to be restored into Vautoload_queue */
1377 record_unwind_protect (un_autoload
, Vautoload_queue
);
1378 Vautoload_queue
= Qt
;
1380 Fload (NULL (file_name
) ? Fsymbol_name (feature
) : file_name
,
1383 tem
= Fmemq (feature
, Vfeatures
);
1385 error ("Required feature %s was not provided",
1386 XSYMBOL (feature
)->name
->data
);
1388 /* Once loading finishes, don't undo it. */
1389 Vautoload_queue
= Qt
;
1390 feature
= unbind_to (count
, feature
);
1397 Qstring_lessp
= intern ("string-lessp");
1398 staticpro (&Qstring_lessp
);
1400 DEFVAR_LISP ("features", &Vfeatures
,
1401 "A list of symbols which are the features of the executing emacs.\n\
1402 Used by `featurep' and `require', and altered by `provide'.");
1405 defsubr (&Sidentity
);
1408 defsubr (&Sstring_equal
);
1409 defsubr (&Sstring_lessp
);
1412 defsubr (&Svconcat
);
1413 defsubr (&Scopy_sequence
);
1414 defsubr (&Scopy_alist
);
1415 defsubr (&Ssubstring
);
1425 defsubr (&Snreverse
);
1426 defsubr (&Sreverse
);
1431 defsubr (&Sfillarray
);
1434 defsubr (&Smapconcat
);
1435 defsubr (&Sy_or_n_p
);
1436 defsubr (&Syes_or_no_p
);
1437 defsubr (&Sload_average
);
1438 defsubr (&Sfeaturep
);
1439 defsubr (&Srequire
);
1440 defsubr (&Sprovide
);