/* Random utility Lisp functions.
- Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc.
+ Copyright (C) 1985, 1986, 1987, 1993, 1994 Free Software Foundation, Inc.
This file is part of GNU Emacs.
the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-#include "config.h"
+#include <config.h>
/* Note on some machines this defines `vector' as a typedef,
so make sure we don't use that name in this file. */
#include "commands.h"
#include "buffer.h"
+#include "keyboard.h"
+#include "intervals.h"
-Lisp_Object Qstring_lessp;
+extern Lisp_Object Flookup_key ();
-static Lisp_Object internal_equal ();
+Lisp_Object Qstring_lessp, Qprovide, Qrequire;
+Lisp_Object Qyes_or_no_p_history;
+
+static int internal_equal ();
\f
DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
"Return the argument unchanged.")
This is 24 bits' worth.\n\
With argument N, return random number in interval [0,N).\n\
With argument t, set the random number seed from the current time and pid.")
- (arg)
- Lisp_Object arg;
+ (limit)
+ Lisp_Object limit;
{
int val;
+ unsigned long denominator;
extern long random ();
extern srandom ();
extern long time ();
- if (EQ (arg, Qt))
+ if (EQ (limit, Qt))
srandom (getpid () + time (0));
- val = random ();
- if (XTYPE (arg) == Lisp_Int && XINT (arg) != 0)
+ if (INTEGERP (limit) && XINT (limit) > 0)
{
- /* Try to take our random number from the higher bits of VAL,
- not the lower, since (says Gentzel) the low bits of `random'
- are less random than the higher ones. */
- val &= 0xfffffff; /* Ensure positive. */
- val >>= 5;
- if (XINT (arg) < 10000)
- val >>= 6;
- val %= XINT (arg);
+ if (XFASTINT (limit) >= 0x40000000)
+ /* This case may occur on 64-bit machines. */
+ val = random () % XFASTINT (limit);
+ else
+ {
+ /* Try to take our random number from the higher bits of VAL,
+ not the lower, since (says Gentzel) the low bits of `random'
+ are less random than the higher ones. We do this by using the
+ quotient rather than the remainder. At the high end of the RNG
+ it's possible to get a quotient larger than limit; discarding
+ these values eliminates the bias that would otherwise appear
+ when using a large limit. */
+ denominator = (unsigned long)0x40000000 / XFASTINT (limit);
+ do
+ val = (random () & 0x3fffffff) / denominator;
+ while (val >= XFASTINT (limit));
+ }
}
+ else
+ val = random ();
return make_number (val);
}
\f
register int i;
retry:
- if (XTYPE (obj) == Lisp_Vector || XTYPE (obj) == Lisp_String
- || XTYPE (obj) == Lisp_Compiled)
- return Farray_length (obj);
+ if (STRINGP (obj))
+ XSETFASTINT (val, XSTRING (obj)->size);
+ else if (VECTORP (obj))
+ XSETFASTINT (val, XVECTOR (obj)->size);
+ else if (COMPILEDP (obj))
+ XSETFASTINT (val, XVECTOR (obj)->size & PSEUDOVECTOR_SIZE_MASK);
else if (CONSP (obj))
{
- for (i = 0, tail = obj; !NILP(tail); i++)
+ for (i = 0, tail = obj; !NILP (tail); i++)
{
QUIT;
tail = Fcdr (tail);
}
- XFASTINT (val) = i;
- return val;
- }
- else if (NILP(obj))
- {
- XFASTINT (val) = 0;
- return val;
+ XSETFASTINT (val, i);
}
+ else if (NILP (obj))
+ XSETFASTINT (val, 0);
else
{
obj = wrong_type_argument (Qsequencep, obj);
goto retry;
}
+ return val;
}
DEFUN ("string-equal", Fstring_equal, Sstring_equal, 2, 2, 0,
"T if two strings have identical contents.\n\
-Case is significant.\n\
+Case is significant, but text properties are ignored.\n\
Symbols are also allowed; their print names are used instead.")
(s1, s2)
register Lisp_Object s1, s2;
{
- if (XTYPE (s1) == Lisp_Symbol)
- XSETSTRING (s1, XSYMBOL (s1)->name), XSETTYPE (s1, Lisp_String);
- if (XTYPE (s2) == Lisp_Symbol)
- XSETSTRING (s2, XSYMBOL (s2)->name), XSETTYPE (s2, Lisp_String);
+ if (SYMBOLP (s1))
+ XSETSTRING (s1, XSYMBOL (s1)->name);
+ if (SYMBOLP (s2))
+ XSETSTRING (s2, XSYMBOL (s2)->name);
CHECK_STRING (s1, 0);
CHECK_STRING (s2, 1);
register unsigned char *p1, *p2;
register int end;
- if (XTYPE (s1) == Lisp_Symbol)
- XSETSTRING (s1, XSYMBOL (s1)->name), XSETTYPE (s1, Lisp_String);
- if (XTYPE (s2) == Lisp_Symbol)
- XSETSTRING (s2, XSYMBOL (s2)->name), XSETTYPE (s2, Lisp_String);
+ if (SYMBOLP (s1))
+ XSETSTRING (s1, XSYMBOL (s1)->name);
+ if (SYMBOLP (s2))
+ XSETSTRING (s2, XSYMBOL (s2)->name);
CHECK_STRING (s1, 0);
CHECK_STRING (s2, 1);
#endif /* NO_ARG_ARRAY */
}
+/* ARGSUSED */
+Lisp_Object
+concat3 (s1, s2, s3)
+ Lisp_Object s1, s2, s3;
+{
+#ifdef NO_ARG_ARRAY
+ Lisp_Object args[3];
+ args[0] = s1;
+ args[1] = s2;
+ args[2] = s3;
+ return concat (3, args, Lisp_String, 0);
+#else
+ return concat (3, &s1, Lisp_String, 0);
+#endif /* NO_ARG_ARRAY */
+}
+
DEFUN ("append", Fappend, Sappend, 0, MANY, 0,
"Concatenate all the arguments and make the result a list.\n\
The result is a list whose elements are the elements of all the arguments.\n\
DEFUN ("concat", Fconcat, Sconcat, 0, MANY, 0,
"Concatenate all the arguments and make the result a string.\n\
The result is a string whose elements are the elements of all the arguments.\n\
-Each argument may be a string, a list of numbers, or a vector of numbers.")
+Each argument may be a string, a list of characters (integers),\n\
+or a vector of characters (integers).")
(nargs, args)
int nargs;
Lisp_Object *args;
int nargs;
Lisp_Object *args;
{
- return concat (nargs, args, Lisp_Vector, 0);
+ return concat (nargs, args, Lisp_Vectorlike, 0);
}
DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0,
Lisp_Object arg;
{
if (NILP (arg)) return arg;
- if (!CONSP (arg) && XTYPE (arg) != Lisp_Vector && XTYPE (arg) != Lisp_String)
+ if (!CONSP (arg) && !VECTORP (arg) && !STRINGP (arg))
arg = wrong_type_argument (Qsequencep, arg);
return concat (1, &arg, CONSP (arg) ? Lisp_Cons : XTYPE (arg), 0);
}
for (argnum = 0; argnum < nargs; argnum++)
{
this = args[argnum];
- if (!(CONSP (this) || NILP (this)
- || XTYPE (this) == Lisp_Vector || XTYPE (this) == Lisp_String
- || XTYPE (this) == Lisp_Compiled))
+ if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
+ || COMPILEDP (this)))
{
- if (XTYPE (this) == Lisp_Int)
- args[argnum] = Fint_to_string (this);
+ if (INTEGERP (this))
+ args[argnum] = Fnumber_to_string (this);
else
args[argnum] = wrong_type_argument (Qsequencep, this);
}
leni += XFASTINT (len);
}
- XFASTINT (len) = leni;
+ XSETFASTINT (len, leni);
if (target_type == Lisp_Cons)
val = Fmake_list (len, Qnil);
- else if (target_type == Lisp_Vector)
+ else if (target_type == Lisp_Vectorlike)
val = Fmake_vector (len, Qnil);
else
val = Fmake_string (len, len);
if (!CONSP (this))
thislen = Flength (this), thisleni = XINT (thislen);
+ if (STRINGP (this) && STRINGP (val)
+ && ! NULL_INTERVAL_P (XSTRING (this)->intervals))
+ {
+ copy_text_properties (make_number (0), thislen, this,
+ make_number (toindex), val, Qnil);
+ }
+
while (1)
{
register Lisp_Object elt;
- /* Fetch next element of `this' arg into `elt', or break if `this' is exhausted. */
+ /* Fetch next element of `this' arg into `elt', or break if
+ `this' is exhausted. */
if (NILP (this)) break;
if (CONSP (this))
elt = Fcar (this), this = Fcdr (this);
else
{
if (thisindex >= thisleni) break;
- if (XTYPE (this) == Lisp_String)
- XFASTINT (elt) = XSTRING (this)->data[thisindex++];
+ if (STRINGP (this))
+ XSETFASTINT (elt, XSTRING (this)->data[thisindex++]);
else
elt = XVECTOR (this)->contents[thisindex++];
}
prev = tail;
tail = XCONS (tail)->cdr;
}
- else if (XTYPE (val) == Lisp_Vector)
+ else if (VECTORP (val))
XVECTOR (val)->contents[toindex++] = elt;
else
{
- while (XTYPE (elt) != Lisp_Int)
+ while (!INTEGERP (elt))
elt = wrong_type_argument (Qintegerp, elt);
{
#ifdef MASSC_REGISTER_BUG
Lisp_Object string;
register Lisp_Object from, to;
{
+ Lisp_Object res;
+
CHECK_STRING (string, 0);
CHECK_NUMBER (from, 1);
if (NILP (to))
&& XINT (to) <= XSTRING (string)->size))
args_out_of_range_3 (string, from, to);
- return make_string (XSTRING (string)->data + XINT (from),
- XINT (to) - XINT (from));
+ res = make_string (XSTRING (string)->data + XINT (from),
+ XINT (to) - XINT (from));
+ copy_text_properties (from, to, string, make_number (0), res, Qnil);
+ return res;
}
\f
DEFUN ("nthcdr", Fnthcdr, Snthcdr, 2, 2, 0,
CHECK_NUMBER (n, 0);
while (1)
{
- if (XTYPE (seq) == Lisp_Cons || NILP (seq))
+ if (CONSP (seq) || NILP (seq))
return Fcar (Fnthcdr (n, seq));
- else if (XTYPE (seq) == Lisp_String
- || XTYPE (seq) == Lisp_Vector)
+ else if (STRINGP (seq) || VECTORP (seq))
return Faref (seq, n);
else
seq = wrong_type_argument (Qsequencep, seq);
}
DEFUN ("member", Fmember, Smember, 2, 2, 0,
- "Return non-nil if ELT is an element of LIST. Comparison done with EQUAL.\n\
+ "Return non-nil if ELT is an element of LIST. Comparison done with `equal'.\n\
The value is actually the tail of LIST whose car is ELT.")
(elt, list)
register Lisp_Object elt;
}
DEFUN ("assq", Fassq, Sassq, 2, 2, 0,
- "Return non-nil if ELT is `eq' to the car of an element of LIST.\n\
-The value is actually the element of LIST whose car is ELT.\n\
+ "Return non-nil if KEY is `eq' to the car of an element of LIST.\n\
+The value is actually the element of LIST whose car is KEY.\n\
Elements of LIST that are not conses are ignored.")
(key, list)
register Lisp_Object key;
}
DEFUN ("assoc", Fassoc, Sassoc, 2, 2, 0,
- "Return non-nil if ELT is `equal' to the car of an element of LIST.\n\
-The value is actually the element of LIST whose car is ELT.")
+ "Return non-nil if KEY is `equal' to the car of an element of LIST.\n\
+The value is actually the element of LIST whose car is KEY.")
(key, list)
register Lisp_Object key;
Lisp_Object list;
DEFUN ("delete", Fdelete, Sdelete, 2, 2, 0,
"Delete by side effect any occurrences of ELT as a member of LIST.\n\
The modified LIST is returned. Comparison is done with `equal'.\n\
-If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
-therefore, write `(setq foo (delete element foo))'\n\
+If the first member of LIST is ELT, deleting it is not a side effect;\n\
+it is simply using a different list.\n\
+Therefore, write `(setq foo (delete element foo))'\n\
to be sure of changing the value of `foo'.")
(elt, list)
register Lisp_Object elt;
while (!NILP (tail))
{
tem = Fcar (tail);
- if (Fequal (elt, tem))
+ if (! NILP (Fequal (elt, tem)))
{
if (NILP (prev))
list = Fcdr (tail);
They must have the same data type.\n\
Conses are compared by comparing the cars and the cdrs.\n\
Vectors and strings are compared element by element.\n\
-Numbers are compared by value. Symbols must match exactly.")
+Numbers are compared by value, but integers cannot equal floats.\n\
+ (Use `=' if you want integers and floats to be able to be equal.)\n\
+Symbols must match exactly.")
(o1, o2)
register Lisp_Object o1, o2;
{
- return internal_equal (o1, o2, 0);
+ return internal_equal (o1, o2, 0) ? Qt : Qnil;
}
-static Lisp_Object
+static int
internal_equal (o1, o2, depth)
register Lisp_Object o1, o2;
int depth;
{
if (depth > 200)
error ("Stack overflow in equal");
-do_cdr:
+ tail_recurse:
QUIT;
- if (XTYPE (o1) != XTYPE (o2)) return Qnil;
- if (XINT (o1) == XINT (o2)) return Qt;
- if (XTYPE (o1) == Lisp_Cons)
+ if (EQ (o1, o2)) return 1;
+#ifdef LISP_FLOAT_TYPE
+ if (FLOATP (o1) && FLOATP (o2))
+ return (extract_float (o1) == extract_float (o2));
+#endif
+ if (XTYPE (o1) != XTYPE (o2)) return 0;
+ if (MISCP (o1) && XMISC (o1)->type != XMISC (o2)->type) return 0;
+ if (CONSP (o1))
{
- Lisp_Object v1;
- v1 = Fequal (Fcar (o1), Fcar (o2), depth + 1);
- if (NILP (v1))
- return v1;
- o1 = Fcdr (o1), o2 = Fcdr (o2);
- goto do_cdr;
+ if (!internal_equal (XCONS (o1)->car, XCONS (o2)->car, depth + 1))
+ return 0;
+ o1 = XCONS (o1)->cdr;
+ o2 = XCONS (o2)->cdr;
+ goto tail_recurse;
}
- if (XTYPE (o1) == Lisp_Marker)
+ if (OVERLAYP (o1))
+ {
+ if (!internal_equal (OVERLAY_START (o1), OVERLAY_START (o1), depth + 1)
+ || !internal_equal (OVERLAY_END (o1), OVERLAY_END (o1), depth + 1))
+ return 0;
+ o1 = XOVERLAY (o1)->plist;
+ o2 = XOVERLAY (o2)->plist;
+ goto tail_recurse;
+ }
+ if (MARKERP (o1))
{
return (XMARKER (o1)->buffer == XMARKER (o2)->buffer
- && XMARKER (o1)->bufpos == XMARKER (o2)->bufpos)
- ? Qt : Qnil;
+ && (XMARKER (o1)->buffer == 0
+ || XMARKER (o1)->bufpos == XMARKER (o2)->bufpos));
}
- if (XTYPE (o1) == Lisp_Vector)
+ if (VECTORP (o1) || COMPILEDP (o1))
{
register int index;
if (XVECTOR (o1)->size != XVECTOR (o2)->size)
- return Qnil;
+ return 0;
for (index = 0; index < XVECTOR (o1)->size; index++)
{
- Lisp_Object v, v1, v2;
+ Lisp_Object v1, v2;
v1 = XVECTOR (o1)->contents [index];
v2 = XVECTOR (o2)->contents [index];
- v = Fequal (v1, v2, depth + 1);
- if (NILP (v)) return v;
+ if (!internal_equal (v1, v2, depth + 1))
+ return 0;
}
- return Qt;
+ return 1;
}
- if (XTYPE (o1) == Lisp_String)
+ if (STRINGP (o1))
{
if (XSTRING (o1)->size != XSTRING (o2)->size)
- return Qnil;
+ return 0;
if (bcmp (XSTRING (o1)->data, XSTRING (o2)->data, XSTRING (o1)->size))
- return Qnil;
- return Qt;
+ return 0;
+#ifdef USE_TEXT_PROPERTIES
+ /* If the strings have intervals, verify they match;
+ if not, they are unequal. */
+ if ((XSTRING (o1)->intervals != 0 || XSTRING (o2)->intervals != 0)
+ && ! compare_string_intervals (o1, o2))
+ return 0;
+#endif
+ return 1;
}
- return Qnil;
+ return 0;
}
\f
DEFUN ("fillarray", Ffillarray, Sfillarray, 2, 2, 0,
{
register int size, index, charval;
retry:
- if (XTYPE (array) == Lisp_Vector)
+ if (VECTORP (array))
{
register Lisp_Object *p = XVECTOR (array)->contents;
size = XVECTOR (array)->size;
for (index = 0; index < size; index++)
p[index] = item;
}
- else if (XTYPE (array) == Lisp_String)
+ else if (STRINGP (array))
{
register unsigned char *p = XSTRING (array)->data;
CHECK_NUMBER (item, 1);
/* We need not explicitly protect `tail' because it is used only on lists, and
1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */
- if (XTYPE (seq) == Lisp_Vector)
+ if (VECTORP (seq))
{
for (i = 0; i < leni; i++)
{
vals[i] = call1 (fn, dummy);
}
}
- else if (XTYPE (seq) == Lisp_String)
+ else if (STRINGP (seq))
{
for (i = 0; i < leni; i++)
{
- XFASTINT (dummy) = XSTRING (seq)->data[i];
+ XSETFASTINT (dummy, XSTRING (seq)->data[i]);
vals[i] = call1 (fn, dummy);
}
}
DEFUN ("mapconcat", Fmapconcat, Smapconcat, 3, 3, 0,
"Apply FN to each element of SEQ, and concat the results as strings.\n\
In between each pair of results, stick in SEP.\n\
-Thus, \" \" as SEP results in spaces between the values return by FN.")
+Thus, \" \" as SEP results in spaces between the values returned by FN.")
(fn, seq, sep)
Lisp_Object fn, seq, sep;
{
(prompt)
Lisp_Object prompt;
{
- register Lisp_Object obj;
- register int ans;
+ register Lisp_Object obj, key, def, answer_string, map;
+ register int answer;
Lisp_Object xprompt;
Lisp_Object args[2];
int ocech = cursor_in_echo_area;
struct gcpro gcpro1, gcpro2;
+ map = Fsymbol_value (intern ("query-replace-map"));
+
CHECK_STRING (prompt, 0);
xprompt = prompt;
GCPRO2 (prompt, xprompt);
while (1)
{
- message ("%s(y or n) ", XSTRING (xprompt)->data);
+#ifdef HAVE_X_MENU
+ if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
+ && using_x_p ())
+ {
+ Lisp_Object pane, menu;
+ redisplay_preserve_echo_area ();
+ pane = Fcons (Fcons (build_string ("Yes"), Qt),
+ Fcons (Fcons (build_string ("No"), Qnil),
+ Qnil));
+ menu = Fcons (prompt, pane);
+ obj = Fx_popup_dialog (Qt, menu);
+ answer = !NILP (obj);
+ break;
+ }
+#endif
cursor_in_echo_area = 1;
+ message ("%s(y or n) ", XSTRING (xprompt)->data);
- obj = read_char (0, 0, 0, Qnil, 0);
- if (XTYPE (obj) == Lisp_Int)
- ans = XINT (obj);
- else
- continue;
+ obj = read_filtered_event (1, 0, 0);
+ cursor_in_echo_area = 0;
+ /* If we need to quit, quit with cursor_in_echo_area = 0. */
+ QUIT;
- cursor_in_echo_area = -1;
- message ("%s(y or n) %c", XSTRING (xprompt)->data, ans);
- cursor_in_echo_area = ocech;
- /* Accept a C-g or C-] (abort-recursive-edit) as quit requests. */
- if (ans == 7 || ans == '\035')
+ key = Fmake_vector (make_number (1), obj);
+ def = Flookup_key (map, key);
+ answer_string = Fsingle_key_description (obj);
+
+ if (EQ (def, intern ("skip")))
+ {
+ answer = 0;
+ break;
+ }
+ else if (EQ (def, intern ("act")))
+ {
+ answer = 1;
+ break;
+ }
+ else if (EQ (def, intern ("recenter")))
+ {
+ Frecenter (Qnil);
+ xprompt = prompt;
+ continue;
+ }
+ else if (EQ (def, intern ("quit")))
+ Vquit_flag = Qt;
+ /* We want to exit this command for exit-prefix,
+ and this is the only way to do it. */
+ else if (EQ (def, intern ("exit-prefix")))
Vquit_flag = Qt;
+
QUIT;
+
+ /* If we don't clear this, then the next call to read_char will
+ return quit_char again, and we'll enter an infinite loop. */
Vquit_flag = Qnil;
- if (ans >= 0)
- ans = DOWNCASE (ans);
- if (ans == 'y' || ans == ' ')
- { ans = 'y'; break; }
- if (ans == 'n' || ans == 127)
- break;
Fding (Qnil);
Fdiscard_input ();
}
}
UNGCPRO;
- return (ans == 'y' ? Qt : Qnil);
+
+ if (! noninteractive)
+ {
+ cursor_in_echo_area = -1;
+ message ("%s(y or n) %c", XSTRING (xprompt)->data, answer ? 'y' : 'n');
+ cursor_in_echo_area = ocech;
+ }
+
+ return answer ? Qt : Qnil;
}
\f
/* This is how C code calls `yes-or-no-p' and allows the user
register Lisp_Object ans;
Lisp_Object args[2];
struct gcpro gcpro1;
+ Lisp_Object menu;
CHECK_STRING (prompt, 0);
+#ifdef HAVE_X_MENU
+ if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
+ && using_x_p ())
+ {
+ Lisp_Object pane, menu, obj;
+ redisplay_preserve_echo_area ();
+ pane = Fcons (Fcons (build_string ("Yes"), Qt),
+ Fcons (Fcons (build_string ("No"), Qnil),
+ Qnil));
+ GCPRO1 (pane);
+ menu = Fcons (prompt, pane);
+ obj = Fx_popup_dialog (Qt, menu);
+ UNGCPRO;
+ return obj;
+ }
+#endif
+
args[0] = prompt;
args[1] = build_string ("(yes or no) ");
prompt = Fconcat (2, args);
GCPRO1 (prompt);
+
while (1)
{
- ans = Fdowncase (Fread_string (prompt, Qnil));
+ ans = Fdowncase (Fread_from_minibuffer (prompt, Qnil, Qnil, Qnil,
+ Qyes_or_no_p_history));
if (XSTRING (ans)->size == 3 && !strcmp (XSTRING (ans)->data, "yes"))
{
UNGCPRO;
message ("Please answer yes or no.");
Fsleep_for (make_number (2), Qnil);
}
- UNGCPRO;
}
\f
DEFUN ("load-average", Fload_average, Sload_average, 0, 0, 0,
tem = Fmemq (feature, Vfeatures);
if (NILP (tem))
Vfeatures = Fcons (feature, Vfeatures);
+ LOADHIST_ATTACH (Fcons (Qprovide, feature));
return feature;
}
register Lisp_Object tem;
CHECK_SYMBOL (feature, 0);
tem = Fmemq (feature, Vfeatures);
+ LOADHIST_ATTACH (Fcons (Qrequire, feature));
if (NILP (tem))
{
int count = specpdl_ptr - specpdl;
{
Qstring_lessp = intern ("string-lessp");
staticpro (&Qstring_lessp);
+ Qprovide = intern ("provide");
+ staticpro (&Qprovide);
+ Qrequire = intern ("require");
+ staticpro (&Qrequire);
+ Qyes_or_no_p_history = intern ("yes-or-no-p-history");
+ staticpro (&Qyes_or_no_p_history);
DEFVAR_LISP ("features", &Vfeatures,
"A list of symbols which are the features of the executing emacs.\n\
HCoop / bpt / emacs.git / blobdiff