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 */
55 #include <sys/dg_sys_info.h> /* for load average info - DJB */
58 /* Note on some machines this defines `vector' as a typedef,
59 so make sure we don't use that name in this file. */
75 Lisp_Object Qstring_lessp
;
77 DEFUN ("identity", Fidentity
, Sidentity
, 1, 1, 0,
78 "Return the argument unchanged.")
85 DEFUN ("random", Frandom
, Srandom
, 0, 1, 0,
86 "Return a pseudo-random number.\n\
87 On most systems all integers representable in Lisp are equally likely.\n\
88 This is 24 bits' worth.\n\
89 With argument N, return random number in interval [0,N).\n\
90 With argument t, set the random number seed from the current time and pid.")
95 extern long random ();
100 srandom (getpid () + time (0));
102 if (XTYPE (arg
) == Lisp_Int
&& XINT (arg
) != 0)
104 /* Try to take our random number from the higher bits of VAL,
105 not the lower, since (says Gentzel) the low bits of `random'
106 are less random than the higher ones. */
107 val
&= 0xfffffff; /* Ensure positive. */
109 if (XINT (arg
) < 10000)
113 return make_number (val
);
116 /* Random data-structure functions */
118 DEFUN ("length", Flength
, Slength
, 1, 1, 0,
119 "Return the length of vector, list or string SEQUENCE.\n\
120 A byte-code function object is also allowed.")
122 register Lisp_Object obj
;
124 register Lisp_Object tail
, val
;
128 if (XTYPE (obj
) == Lisp_Vector
|| XTYPE (obj
) == Lisp_String
129 || XTYPE (obj
) == Lisp_Compiled
)
130 return Farray_length (obj
);
131 else if (CONSP (obj
))
133 for (i
= 0, tail
= obj
; !NULL(tail
); i
++)
149 obj
= wrong_type_argument (Qsequencep
, obj
);
154 DEFUN ("string-equal", Fstring_equal
, Sstring_equal
, 2, 2, 0,
155 "T if two strings have identical contents.\n\
156 Case is significant.\n\
157 Symbols are also allowed; their print names are used instead.")
159 register Lisp_Object s1
, s2
;
161 if (XTYPE (s1
) == Lisp_Symbol
)
162 XSETSTRING (s1
, XSYMBOL (s1
)->name
), XSETTYPE (s1
, Lisp_String
);
163 if (XTYPE (s2
) == Lisp_Symbol
)
164 XSETSTRING (s2
, XSYMBOL (s2
)->name
), XSETTYPE (s2
, Lisp_String
);
165 CHECK_STRING (s1
, 0);
166 CHECK_STRING (s2
, 1);
168 if (XSTRING (s1
)->size
!= XSTRING (s2
)->size
||
169 bcmp (XSTRING (s1
)->data
, XSTRING (s2
)->data
, XSTRING (s1
)->size
))
174 DEFUN ("string-lessp", Fstring_lessp
, Sstring_lessp
, 2, 2, 0,
175 "T if first arg string is less than second in lexicographic order.\n\
176 Case is significant.\n\
177 Symbols are also allowed; their print names are used instead.")
179 register Lisp_Object s1
, s2
;
182 register unsigned char *p1
, *p2
;
185 if (XTYPE (s1
) == Lisp_Symbol
)
186 XSETSTRING (s1
, XSYMBOL (s1
)->name
), XSETTYPE (s1
, Lisp_String
);
187 if (XTYPE (s2
) == Lisp_Symbol
)
188 XSETSTRING (s2
, XSYMBOL (s2
)->name
), XSETTYPE (s2
, Lisp_String
);
189 CHECK_STRING (s1
, 0);
190 CHECK_STRING (s2
, 1);
192 p1
= XSTRING (s1
)->data
;
193 p2
= XSTRING (s2
)->data
;
194 end
= XSTRING (s1
)->size
;
195 if (end
> XSTRING (s2
)->size
)
196 end
= XSTRING (s2
)->size
;
198 for (i
= 0; i
< end
; i
++)
201 return p1
[i
] < p2
[i
] ? Qt
: Qnil
;
203 return i
< XSTRING (s2
)->size
? Qt
: Qnil
;
206 static Lisp_Object
concat ();
217 return concat (2, args
, Lisp_String
, 0);
219 return concat (2, &s1
, Lisp_String
, 0);
220 #endif /* NO_ARG_ARRAY */
223 DEFUN ("append", Fappend
, Sappend
, 0, MANY
, 0,
224 "Concatenate all the arguments and make the result a list.\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.\n\
227 The last argument is not copied if it is a list.")
232 return concat (nargs
, args
, Lisp_Cons
, 1);
235 DEFUN ("concat", Fconcat
, Sconcat
, 0, MANY
, 0,
236 "Concatenate all the arguments and make the result a string.\n\
237 The result is a string whose elements are the elements of all the arguments.\n\
238 Each argument may be a string, a list of numbers, or a vector of numbers.")
243 return concat (nargs
, args
, Lisp_String
, 0);
246 DEFUN ("vconcat", Fvconcat
, Svconcat
, 0, MANY
, 0,
247 "Concatenate all the arguments and make the result a vector.\n\
248 The result is a vector whose elements are the elements of all the arguments.\n\
249 Each argument may be a list, vector or string.")
254 return concat (nargs
, args
, Lisp_Vector
, 0);
257 DEFUN ("copy-sequence", Fcopy_sequence
, Scopy_sequence
, 1, 1, 0,
258 "Return a copy of a list, vector or string.\n\
259 The elements of a list or vector are not copied; they are shared\n\
264 if (NULL (arg
)) return arg
;
265 if (!CONSP (arg
) && XTYPE (arg
) != Lisp_Vector
&& XTYPE (arg
) != Lisp_String
)
266 arg
= wrong_type_argument (Qsequencep
, arg
);
267 return concat (1, &arg
, CONSP (arg
) ? Lisp_Cons
: XTYPE (arg
), 0);
271 concat (nargs
, args
, target_type
, last_special
)
274 enum Lisp_Type target_type
;
279 register Lisp_Object tail
;
280 register Lisp_Object
this;
284 Lisp_Object last_tail
;
287 /* In append, the last arg isn't treated like the others */
288 if (last_special
&& nargs
> 0)
291 last_tail
= args
[nargs
];
296 for (argnum
= 0; argnum
< nargs
; argnum
++)
299 if (!(CONSP (this) || NULL (this)
300 || XTYPE (this) == Lisp_Vector
|| XTYPE (this) == Lisp_String
301 || XTYPE (this) == Lisp_Compiled
))
303 if (XTYPE (this) == Lisp_Int
)
304 args
[argnum
] = Fint_to_string (this);
306 args
[argnum
] = wrong_type_argument (Qsequencep
, this);
310 for (argnum
= 0, leni
= 0; argnum
< nargs
; argnum
++)
313 len
= Flength (this);
314 leni
+= XFASTINT (len
);
317 XFASTINT (len
) = leni
;
319 if (target_type
== Lisp_Cons
)
320 val
= Fmake_list (len
, Qnil
);
321 else if (target_type
== Lisp_Vector
)
322 val
= Fmake_vector (len
, Qnil
);
324 val
= Fmake_string (len
, len
);
326 /* In append, if all but last arg are nil, return last arg */
327 if (target_type
== Lisp_Cons
&& EQ (val
, Qnil
))
331 tail
= val
, toindex
= -1; /* -1 in toindex is flag we are making a list */
337 for (argnum
= 0; argnum
< nargs
; argnum
++)
341 register int thisindex
= 0;
345 thislen
= Flength (this), thisleni
= XINT (thislen
);
349 register Lisp_Object elt
;
351 /* Fetch next element of `this' arg into `elt', or break if `this' is exhausted. */
352 if (NULL (this)) break;
354 elt
= Fcar (this), this = Fcdr (this);
357 if (thisindex
>= thisleni
) break;
358 if (XTYPE (this) == Lisp_String
)
359 XFASTINT (elt
) = XSTRING (this)->data
[thisindex
++];
361 elt
= XVECTOR (this)->contents
[thisindex
++];
364 /* Store into result */
367 XCONS (tail
)->car
= elt
;
369 tail
= XCONS (tail
)->cdr
;
371 else if (XTYPE (val
) == Lisp_Vector
)
372 XVECTOR (val
)->contents
[toindex
++] = elt
;
375 while (XTYPE (elt
) != Lisp_Int
)
376 elt
= wrong_type_argument (Qintegerp
, elt
);
378 #ifdef MASSC_REGISTER_BUG
379 /* Even removing all "register"s doesn't disable this bug!
380 Nothing simpler than this seems to work. */
381 unsigned char *p
= & XSTRING (val
)->data
[toindex
++];
384 XSTRING (val
)->data
[toindex
++] = XINT (elt
);
391 XCONS (prev
)->cdr
= last_tail
;
396 DEFUN ("copy-alist", Fcopy_alist
, Scopy_alist
, 1, 1, 0,
397 "Return a copy of ALIST.\n\
398 This is an alist which represents the same mapping from objects to objects,\n\
399 but does not share the alist structure with ALIST.\n\
400 The objects mapped (cars and cdrs of elements of the alist)\n\
401 are shared, however.\n\
402 Elements of ALIST that are not conses are also shared.")
406 register Lisp_Object tem
;
408 CHECK_LIST (alist
, 0);
411 alist
= concat (1, &alist
, Lisp_Cons
, 0);
412 for (tem
= alist
; CONSP (tem
); tem
= XCONS (tem
)->cdr
)
414 register Lisp_Object car
;
415 car
= XCONS (tem
)->car
;
418 XCONS (tem
)->car
= Fcons (XCONS (car
)->car
, XCONS (car
)->cdr
);
423 DEFUN ("substring", Fsubstring
, Ssubstring
, 2, 3, 0,
424 "Return a substring of STRING, starting at index FROM and ending before TO.\n\
425 TO may be nil or omitted; then the substring runs to the end of STRING.\n\
426 If FROM or TO is negative, it counts from the end.")
429 register Lisp_Object from
, to
;
431 CHECK_STRING (string
, 0);
432 CHECK_NUMBER (from
, 1);
434 to
= Flength (string
);
436 CHECK_NUMBER (to
, 2);
439 XSETINT (from
, XINT (from
) + XSTRING (string
)->size
);
441 XSETINT (to
, XINT (to
) + XSTRING (string
)->size
);
442 if (!(0 <= XINT (from
) && XINT (from
) <= XINT (to
)
443 && XINT (to
) <= XSTRING (string
)->size
))
444 args_out_of_range_3 (string
, from
, to
);
446 return make_string (XSTRING (string
)->data
+ XINT (from
),
447 XINT (to
) - XINT (from
));
450 DEFUN ("nthcdr", Fnthcdr
, Snthcdr
, 2, 2, 0,
451 "Take cdr N times on LIST, returns the result.")
454 register Lisp_Object list
;
459 for (i
= 0; i
< num
&& !NULL (list
); i
++)
467 DEFUN ("nth", Fnth
, Snth
, 2, 2, 0,
468 "Return the Nth element of LIST.\n\
469 N counts from zero. If LIST is not that long, nil is returned.")
473 return Fcar (Fnthcdr (n
, list
));
476 DEFUN ("elt", Felt
, Selt
, 2, 2, 0,
477 "Return element of SEQUENCE at index N.")
479 register Lisp_Object seq
, n
;
484 if (XTYPE (seq
) == Lisp_Cons
|| NULL (seq
))
485 return Fcar (Fnthcdr (n
, seq
));
486 else if (XTYPE (seq
) == Lisp_String
||
487 XTYPE (seq
) == Lisp_Vector
)
488 return Faref (seq
, n
);
490 seq
= wrong_type_argument (Qsequencep
, seq
);
494 DEFUN ("member", Fmember
, Smember
, 2, 2, 0,
495 "Return non-nil if ELT is an element of LIST. Comparison done with EQUAL.\n\
496 The value is actually the tail of LIST whose car is ELT.")
498 register Lisp_Object elt
;
501 register Lisp_Object tail
;
502 for (tail
= list
; !NULL (tail
); tail
= Fcdr (tail
))
504 register Lisp_Object tem
;
506 if (! NULL (Fequal (elt
, tem
)))
513 DEFUN ("memq", Fmemq
, Smemq
, 2, 2, 0,
514 "Return non-nil if ELT is an element of LIST. Comparison done with EQ.\n\
515 The value is actually the tail of LIST whose car is ELT.")
517 register Lisp_Object elt
;
520 register Lisp_Object tail
;
521 for (tail
= list
; !NULL (tail
); tail
= Fcdr (tail
))
523 register Lisp_Object tem
;
525 if (EQ (elt
, tem
)) return tail
;
531 DEFUN ("assq", Fassq
, Sassq
, 2, 2, 0,
532 "Return non-nil if ELT is `eq' to the car of an element of LIST.\n\
533 The value is actually the element of LIST whose car is ELT.\n\
534 Elements of LIST that are not conses are ignored.")
536 register Lisp_Object key
;
539 register Lisp_Object tail
;
540 for (tail
= list
; !NULL (tail
); tail
= Fcdr (tail
))
542 register Lisp_Object elt
, tem
;
544 if (!CONSP (elt
)) continue;
546 if (EQ (key
, tem
)) return elt
;
552 /* Like Fassq but never report an error and do not allow quits.
553 Use only on lists known never to be circular. */
556 assq_no_quit (key
, list
)
557 register Lisp_Object key
;
560 register Lisp_Object tail
;
561 for (tail
= list
; CONSP (tail
); tail
= Fcdr (tail
))
563 register Lisp_Object elt
, tem
;
565 if (!CONSP (elt
)) continue;
567 if (EQ (key
, tem
)) return elt
;
572 DEFUN ("assoc", Fassoc
, Sassoc
, 2, 2, 0,
573 "Return non-nil if ELT is `equal' to the car of an element of LIST.\n\
574 The value is actually the element of LIST whose car is ELT.")
576 register Lisp_Object key
;
579 register Lisp_Object tail
;
580 for (tail
= list
; !NULL (tail
); tail
= Fcdr (tail
))
582 register Lisp_Object elt
, tem
;
584 if (!CONSP (elt
)) continue;
585 tem
= Fequal (Fcar (elt
), key
);
586 if (!NULL (tem
)) return elt
;
592 DEFUN ("rassq", Frassq
, Srassq
, 2, 2, 0,
593 "Return non-nil if ELT is `eq' to the cdr of an element of LIST.\n\
594 The value is actually the element of LIST whose cdr is ELT.")
596 register Lisp_Object key
;
599 register Lisp_Object tail
;
600 for (tail
= list
; !NULL (tail
); tail
= Fcdr (tail
))
602 register Lisp_Object elt
, tem
;
604 if (!CONSP (elt
)) continue;
606 if (EQ (key
, tem
)) return elt
;
612 DEFUN ("delq", Fdelq
, Sdelq
, 2, 2, 0,
613 "Delete by side effect any occurrences of ELT as a member of LIST.\n\
614 The modified LIST is returned. Comparison is done with `eq'.\n\
615 If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
616 therefore, write `(setq foo (delq element foo))'\n\
617 to be sure of changing the value of `foo'.")
619 register Lisp_Object elt
;
622 register Lisp_Object tail
, prev
;
623 register Lisp_Object tem
;
635 Fsetcdr (prev
, Fcdr (tail
));
645 DEFUN ("nreverse", Fnreverse
, Snreverse
, 1, 1, 0,
646 "Reverse LIST by modifying cdr pointers.\n\
647 Returns the beginning of the reversed list.")
651 register Lisp_Object prev
, tail
, next
;
653 if (NULL (list
)) return list
;
660 Fsetcdr (tail
, prev
);
667 DEFUN ("reverse", Freverse
, Sreverse
, 1, 1, 0,
668 "Reverse LIST, copying. Returns the beginning of the reversed list.\n\
669 See also the function `nreverse', which is used more often.")
674 register Lisp_Object
*vec
;
675 register Lisp_Object tail
;
678 length
= Flength (list
);
679 vec
= (Lisp_Object
*) alloca (XINT (length
) * sizeof (Lisp_Object
));
680 for (i
= XINT (length
) - 1, tail
= list
; i
>= 0; i
--, tail
= Fcdr (tail
))
681 vec
[i
] = Fcar (tail
);
683 return Flist (XINT (length
), vec
);
686 Lisp_Object
merge ();
688 DEFUN ("sort", Fsort
, Ssort
, 2, 2, 0,
689 "Sort LIST, stably, comparing elements using PREDICATE.\n\
690 Returns the sorted list. LIST is modified by side effects.\n\
691 PREDICATE is called with two elements of LIST, and should return T\n\
692 if the first element is \"less\" than the second.")
694 Lisp_Object list
, pred
;
696 Lisp_Object front
, back
;
697 register Lisp_Object len
, tem
;
698 struct gcpro gcpro1
, gcpro2
;
702 len
= Flength (list
);
707 XSETINT (len
, (length
/ 2) - 1);
708 tem
= Fnthcdr (len
, list
);
712 GCPRO2 (front
, back
);
713 front
= Fsort (front
, pred
);
714 back
= Fsort (back
, pred
);
716 return merge (front
, back
, pred
);
720 merge (org_l1
, org_l2
, pred
)
721 Lisp_Object org_l1
, org_l2
;
725 register Lisp_Object tail
;
727 register Lisp_Object l1
, l2
;
728 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
735 /* It is sufficient to protect org_l1 and org_l2.
736 When l1 and l2 are updated, we copy the new values
737 back into the org_ vars. */
738 GCPRO4 (org_l1
, org_l2
, pred
, value
);
758 tem
= call2 (pred
, Fcar (l2
), Fcar (l1
));
779 DEFUN ("get", Fget
, Sget
, 2, 2, 0,
780 "Return the value of SYMBOL's PROPNAME property.\n\
781 This is the last VALUE stored with `(put SYMBOL PROPNAME VALUE)'.")
784 register Lisp_Object prop
;
786 register Lisp_Object tail
;
787 for (tail
= Fsymbol_plist (sym
); !NULL (tail
); tail
= Fcdr (Fcdr (tail
)))
789 register Lisp_Object tem
;
792 return Fcar (Fcdr (tail
));
797 DEFUN ("put", Fput
, Sput
, 3, 3, 0,
798 "Store SYMBOL's PROPNAME property with value VALUE.\n\
799 It can be retrieved with `(get SYMBOL PROPNAME)'.")
802 register Lisp_Object prop
;
805 register Lisp_Object tail
, prev
;
808 for (tail
= Fsymbol_plist (sym
); !NULL (tail
); tail
= Fcdr (Fcdr (tail
)))
810 register Lisp_Object tem
;
813 return Fsetcar (Fcdr (tail
), val
);
816 newcell
= Fcons (prop
, Fcons (val
, Qnil
));
818 Fsetplist (sym
, newcell
);
820 Fsetcdr (Fcdr (prev
), newcell
);
824 DEFUN ("equal", Fequal
, Sequal
, 2, 2, 0,
825 "T if two Lisp objects have similar structure and contents.\n\
826 They must have the same data type.\n\
827 Conses are compared by comparing the cars and the cdrs.\n\
828 Vectors and strings are compared element by element.\n\
829 Numbers are compared by value. Symbols must match exactly.")
831 register Lisp_Object o1
, o2
;
835 if (XTYPE (o1
) != XTYPE (o2
)) return Qnil
;
836 if (XINT (o1
) == XINT (o2
)) return Qt
;
837 if (XTYPE (o1
) == Lisp_Cons
)
840 v1
= Fequal (Fcar (o1
), Fcar (o2
));
843 o1
= Fcdr (o1
), o2
= Fcdr (o2
);
846 if (XTYPE (o1
) == Lisp_Marker
)
848 return (XMARKER (o1
)->buffer
== XMARKER (o2
)->buffer
849 && XMARKER (o1
)->bufpos
== XMARKER (o2
)->bufpos
)
852 if (XTYPE (o1
) == Lisp_Vector
)
855 if (XVECTOR (o1
)->size
!= XVECTOR (o2
)->size
)
857 for (index
= 0; index
< XVECTOR (o1
)->size
; index
++)
859 Lisp_Object v
, v1
, v2
;
860 v1
= XVECTOR (o1
)->contents
[index
];
861 v2
= XVECTOR (o2
)->contents
[index
];
863 if (NULL (v
)) return v
;
867 if (XTYPE (o1
) == Lisp_String
)
869 if (XSTRING (o1
)->size
!= XSTRING (o2
)->size
)
871 if (bcmp (XSTRING (o1
)->data
, XSTRING (o2
)->data
, XSTRING (o1
)->size
))
878 DEFUN ("fillarray", Ffillarray
, Sfillarray
, 2, 2, 0,
879 "Store each element of ARRAY with ITEM. ARRAY is a vector or string.")
881 Lisp_Object array
, item
;
883 register int size
, index
, charval
;
885 if (XTYPE (array
) == Lisp_Vector
)
887 register Lisp_Object
*p
= XVECTOR (array
)->contents
;
888 size
= XVECTOR (array
)->size
;
889 for (index
= 0; index
< size
; index
++)
892 else if (XTYPE (array
) == Lisp_String
)
894 register unsigned char *p
= XSTRING (array
)->data
;
895 CHECK_NUMBER (item
, 1);
896 charval
= XINT (item
);
897 size
= XSTRING (array
)->size
;
898 for (index
= 0; index
< size
; index
++)
903 array
= wrong_type_argument (Qarrayp
, array
);
918 return Fnconc (2, args
);
920 return Fnconc (2, &s1
);
921 #endif /* NO_ARG_ARRAY */
924 DEFUN ("nconc", Fnconc
, Snconc
, 0, MANY
, 0,
925 "Concatenate any number of lists by altering them.\n\
926 Only the last argument is not altered, and need not be a list.")
932 register Lisp_Object tail
, tem
, val
;
936 for (argnum
= 0; argnum
< nargs
; argnum
++)
939 if (NULL (tem
)) continue;
944 if (argnum
+ 1 == nargs
) break;
947 tem
= wrong_type_argument (Qlistp
, tem
);
956 tem
= args
[argnum
+ 1];
959 args
[argnum
+ 1] = tail
;
965 /* This is the guts of all mapping functions.
966 Apply fn to each element of seq, one by one,
967 storing the results into elements of vals, a C vector of Lisp_Objects.
968 leni is the length of vals, which should also be the length of seq. */
971 mapcar1 (leni
, vals
, fn
, seq
)
976 register Lisp_Object tail
;
979 struct gcpro gcpro1
, gcpro2
, gcpro3
;
981 /* Don't let vals contain any garbage when GC happens. */
982 for (i
= 0; i
< leni
; i
++)
985 GCPRO3 (dummy
, fn
, seq
);
988 /* We need not explicitly protect `tail' because it is used only on lists, and
989 1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
991 if (XTYPE (seq
) == Lisp_Vector
)
993 for (i
= 0; i
< leni
; i
++)
995 dummy
= XVECTOR (seq
)->contents
[i
];
996 vals
[i
] = call1 (fn
, dummy
);
999 else if (XTYPE (seq
) == Lisp_String
)
1001 for (i
= 0; i
< leni
; i
++)
1003 XFASTINT (dummy
) = XSTRING (seq
)->data
[i
];
1004 vals
[i
] = call1 (fn
, dummy
);
1007 else /* Must be a list, since Flength did not get an error */
1010 for (i
= 0; i
< leni
; i
++)
1012 vals
[i
] = call1 (fn
, Fcar (tail
));
1020 DEFUN ("mapconcat", Fmapconcat
, Smapconcat
, 3, 3, 0,
1021 "Apply FN to each element of SEQ, and concat the results as strings.\n\
1022 In between each pair of results, stick in SEP.\n\
1023 Thus, \" \" as SEP results in spaces between the values return by FN.")
1025 Lisp_Object fn
, seq
, sep
;
1030 register Lisp_Object
*args
;
1032 struct gcpro gcpro1
;
1034 len
= Flength (seq
);
1036 nargs
= leni
+ leni
- 1;
1037 if (nargs
< 0) return build_string ("");
1039 args
= (Lisp_Object
*) alloca (nargs
* sizeof (Lisp_Object
));
1042 mapcar1 (leni
, args
, fn
, seq
);
1045 for (i
= leni
- 1; i
>= 0; i
--)
1046 args
[i
+ i
] = args
[i
];
1048 for (i
= 1; i
< nargs
; i
+= 2)
1051 return Fconcat (nargs
, args
);
1054 DEFUN ("mapcar", Fmapcar
, Smapcar
, 2, 2, 0,
1055 "Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
1056 The result is a list just as long as SEQUENCE.\n\
1057 SEQUENCE may be a list, a vector or a string.")
1059 Lisp_Object fn
, seq
;
1061 register Lisp_Object len
;
1063 register Lisp_Object
*args
;
1065 len
= Flength (seq
);
1066 leni
= XFASTINT (len
);
1067 args
= (Lisp_Object
*) alloca (leni
* sizeof (Lisp_Object
));
1069 mapcar1 (leni
, args
, fn
, seq
);
1071 return Flist (leni
, args
);
1074 /* Anything that calls this function must protect from GC! */
1076 DEFUN ("y-or-n-p", Fy_or_n_p
, Sy_or_n_p
, 1, 1, 0,
1077 "Ask user a \"y or n\" question. Return t if answer is \"y\".\n\
1078 No confirmation of the answer is requested; a single character is enough.\n\
1079 Also accepts Space to mean yes, or Delete to mean no.")
1083 register Lisp_Object obj
;
1085 Lisp_Object xprompt
;
1086 Lisp_Object args
[2];
1087 int ocech
= cursor_in_echo_area
;
1088 struct gcpro gcpro1
, gcpro2
;
1090 CHECK_STRING (prompt
, 0);
1092 GCPRO2 (prompt
, xprompt
);
1096 message ("%s(y or n) ", XSTRING (xprompt
)->data
);
1097 cursor_in_echo_area
= 1;
1099 obj
= read_char (0);
1100 if (XTYPE (obj
) == Lisp_Int
)
1105 cursor_in_echo_area
= -1;
1106 message ("%s(y or n) %c", XSTRING (xprompt
)->data
, ans
);
1107 cursor_in_echo_area
= ocech
;
1108 /* Accept a C-g or C-] (abort-recursive-edit) as quit requests. */
1109 if (ans
== 7 || ans
== '\035')
1113 ans
= DOWNCASE (ans
);
1114 if (ans
== 'y' || ans
== ' ')
1115 { ans
= 'y'; break; }
1116 if (ans
== 'n' || ans
== 127)
1121 if (EQ (xprompt
, prompt
))
1123 args
[0] = build_string ("Please answer y or n. ");
1125 xprompt
= Fconcat (2, args
);
1129 return (ans
== 'y' ? Qt
: Qnil
);
1132 /* This is how C code calls `yes-or-no-p' and allows the user
1135 Anything that calls this function must protect from GC! */
1138 do_yes_or_no_p (prompt
)
1141 return call1 (intern ("yes-or-no-p"), prompt
);
1144 /* Anything that calls this function must protect from GC! */
1146 DEFUN ("yes-or-no-p", Fyes_or_no_p
, Syes_or_no_p
, 1, 1, 0,
1147 "Ask user a yes or no question. Return t if answer is yes.\n\
1148 The user must confirm the answer with a newline,\n\
1149 and can rub it out if not confirmed.")
1153 register Lisp_Object ans
;
1154 Lisp_Object args
[2];
1155 struct gcpro gcpro1
;
1157 CHECK_STRING (prompt
, 0);
1160 args
[1] = build_string ("(yes or no) ");
1161 prompt
= Fconcat (2, args
);
1166 ans
= Fdowncase (read_minibuf (Vminibuffer_local_map
,
1167 Qnil
, prompt
, Qnil
, 0));
1168 if (XSTRING (ans
)->size
== 3 && !strcmp (XSTRING (ans
)->data
, "yes"))
1173 if (XSTRING (ans
)->size
== 2 && !strcmp (XSTRING (ans
)->data
, "no"))
1181 message ("Please answer yes or no.");
1182 Fsleep_for (make_number (2));
1187 /* Avoid static vars inside a function since in HPUX they dump as pure. */
1189 static struct dg_sys_info_load_info load_info
; /* what-a-mouthful! */
1191 #else /* Not DGUX */
1193 static int ldav_initialized
;
1194 static int ldav_channel
;
1195 #ifdef LOAD_AVE_TYPE
1197 static struct nlist ldav_nl
[2];
1199 #endif /* LOAD_AVE_TYPE */
1201 #define channel ldav_channel
1202 #define initialized ldav_initialized
1204 #endif /* Not DGUX */
1206 DEFUN ("load-average", Fload_average
, Sload_average
, 0, 0, 0,
1207 "Return list of 1 minute, 5 minute and 15 minute load averages.\n\
1208 Each of the three load averages is multiplied by 100,\n\
1209 then converted to integer.")
1213 /* perhaps there should be a "sys_load_avg" call in sysdep.c?! - DJB */
1214 load_info
.one_minute
= 0.0; /* just in case there is an error */
1215 load_info
.five_minute
= 0.0;
1216 load_info
.fifteen_minute
= 0.0;
1217 dg_sys_info (&load_info
, DG_SYS_INFO_LOAD_INFO_TYPE
,
1218 DG_SYS_INFO_LOAD_VERSION_0
);
1220 return Fcons (make_number ((int)(load_info
.one_minute
* 100.0)),
1221 Fcons (make_number ((int)(load_info
.five_minute
* 100.0)),
1222 Fcons (make_number ((int)(load_info
.fifteen_minute
* 100.0)),
1224 #else /* not DGUX */
1225 #ifndef LOAD_AVE_TYPE
1226 error ("load-average not implemented for this operating system");
1228 #else /* LOAD_AVE_TYPE defined */
1230 LOAD_AVE_TYPE load_ave
[3];
1234 #include <descrip.h>
1236 #include <vms/iodef.h>
1237 struct {int dsc$w_length
; char *dsc$a_pointer
;} descriptor
;
1241 /* If this fails for any reason, we can return (0 0 0) */
1242 load_ave
[0] = 0.0; load_ave
[1] = 0.0; load_ave
[2] = 0.0;
1246 * VMS specific code -- read from the Load Ave driver
1250 * Ensure that there is a channel open to the load ave device
1252 if (initialized
== 0)
1254 /* Attempt to open the channel */
1256 descriptor
.size
= 18;
1257 descriptor
.ptr
= "$$VMS_LOAD_AVERAGE";
1259 $
DESCRIPTOR(descriptor
, "LAV0:");
1261 if (sys$
assign (&descriptor
, &channel
, 0, 0) & 1)
1265 * Read the load average vector
1269 if (!(sys$
qiow (0, channel
, IO$_READVBLK
, 0, 0, 0,
1270 load_ave
, 12, 0, 0, 0, 0)
1273 sys$
dassgn (channel
);
1279 * 4.2BSD UNIX-specific code -- read _avenrun from /dev/kmem
1283 * Make sure we have the address of _avenrun
1285 if (nl
[0].n_value
== 0)
1288 * Get the address of _avenrun
1290 #ifndef NLIST_STRUCT
1291 strcpy (nl
[0].n_name
, LDAV_SYMBOL
);
1293 #else /* NLIST_STRUCT */
1295 nl
[0].n_un
.n_name
= LDAV_SYMBOL
;
1296 nl
[1].n_un
.n_name
= 0;
1297 #else /* not convex */
1298 nl
[0].n_name
= LDAV_SYMBOL
;
1300 #endif /* not convex */
1301 #endif /* NLIST_STRUCT */
1303 nlist (KERNEL_FILE
, nl
);
1305 #ifdef FIXUP_KERNEL_SYMBOL_ADDR
1306 FIXUP_KERNEL_SYMBOL_ADDR (nl
);
1307 #endif /* FIXUP_KERNEL_SYMBOL_ADDR */
1310 * Make sure we have /dev/kmem open
1312 if (initialized
== 0)
1317 channel
= open ("/dev/kmem", 0);
1318 if (channel
>= 0) initialized
= 1;
1321 * If we can, get the load ave values
1323 if ((nl
[0].n_value
!= 0) && (initialized
!= 0))
1326 * Seek to the correct address
1328 lseek (channel
, (long) nl
[0].n_value
, 0);
1329 if (read (channel
, load_ave
, sizeof load_ave
)
1330 != sizeof(load_ave
))
1336 #endif /* not VMS */
1339 * Return the list of load average values
1341 return Fcons (make_number (LOAD_AVE_CVT (load_ave
[0])),
1342 Fcons (make_number (LOAD_AVE_CVT (load_ave
[1])),
1343 Fcons (make_number (LOAD_AVE_CVT (load_ave
[2])),
1345 #endif /* LOAD_AVE_TYPE */
1346 #endif /* not DGUX */
1353 Lisp_Object Vfeatures
;
1355 DEFUN ("featurep", Ffeaturep
, Sfeaturep
, 1, 1, 0,
1356 "Returns t if FEATURE is present in this Emacs.\n\
1357 Use this to conditionalize execution of lisp code based on the presence or\n\
1358 absence of emacs or environment extensions.\n\
1359 Use `provide' to declare that a feature is available.\n\
1360 This function looks at the value of the variable `features'.")
1362 Lisp_Object feature
;
1364 register Lisp_Object tem
;
1365 CHECK_SYMBOL (feature
, 0);
1366 tem
= Fmemq (feature
, Vfeatures
);
1367 return (NULL (tem
)) ? Qnil
: Qt
;
1370 DEFUN ("provide", Fprovide
, Sprovide
, 1, 1, 0,
1371 "Announce that FEATURE is a feature of the current Emacs.")
1373 Lisp_Object feature
;
1375 register Lisp_Object tem
;
1376 CHECK_SYMBOL (feature
, 0);
1377 if (!NULL (Vautoload_queue
))
1378 Vautoload_queue
= Fcons (Fcons (Vfeatures
, Qnil
), Vautoload_queue
);
1379 tem
= Fmemq (feature
, Vfeatures
);
1381 Vfeatures
= Fcons (feature
, Vfeatures
);
1385 DEFUN ("require", Frequire
, Srequire
, 1, 2, 0,
1386 "If feature FEATURE is not loaded, load it from FILENAME.\n\
1387 If FEATURE is not a member of the list `features', then the feature\n\
1388 is not loaded; so load the file FILENAME.\n\
1389 If FILENAME is omitted, the printname of FEATURE is used as the file name.")
1390 (feature
, file_name
)
1391 Lisp_Object feature
, file_name
;
1393 register Lisp_Object tem
;
1394 CHECK_SYMBOL (feature
, 0);
1395 tem
= Fmemq (feature
, Vfeatures
);
1398 int count
= specpdl_ptr
- specpdl
;
1400 /* Value saved here is to be restored into Vautoload_queue */
1401 record_unwind_protect (un_autoload
, Vautoload_queue
);
1402 Vautoload_queue
= Qt
;
1404 Fload (NULL (file_name
) ? Fsymbol_name (feature
) : file_name
,
1407 tem
= Fmemq (feature
, Vfeatures
);
1409 error ("Required feature %s was not provided",
1410 XSYMBOL (feature
)->name
->data
);
1412 /* Once loading finishes, don't undo it. */
1413 Vautoload_queue
= Qt
;
1414 feature
= unbind_to (count
, feature
);
1421 Qstring_lessp
= intern ("string-lessp");
1422 staticpro (&Qstring_lessp
);
1424 DEFVAR_LISP ("features", &Vfeatures
,
1425 "A list of symbols which are the features of the executing emacs.\n\
1426 Used by `featurep' and `require', and altered by `provide'.");
1429 defsubr (&Sidentity
);
1432 defsubr (&Sstring_equal
);
1433 defsubr (&Sstring_lessp
);
1436 defsubr (&Svconcat
);
1437 defsubr (&Scopy_sequence
);
1438 defsubr (&Scopy_alist
);
1439 defsubr (&Ssubstring
);
1449 defsubr (&Snreverse
);
1450 defsubr (&Sreverse
);
1455 defsubr (&Sfillarray
);
1458 defsubr (&Smapconcat
);
1459 defsubr (&Sy_or_n_p
);
1460 defsubr (&Syes_or_no_p
);
1461 defsubr (&Sload_average
);
1462 defsubr (&Sfeaturep
);
1463 defsubr (&Srequire
);
1464 defsubr (&Sprovide
);