Commit 7b863bd5 authored by Jim Blandy's avatar Jim Blandy
Browse files

Initial revision

parent 073c9531
/* Random utility Lisp functions.
Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc.
This file is part of GNU Emacs.
GNU Emacs is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 1, or (at your option)
any later version.
GNU Emacs is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with GNU Emacs; see the file COPYING. If not, write to
the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
#include "config.h"
#ifdef LOAD_AVE_TYPE
#ifdef BSD
/* It appears param.h defines BSD and BSD4_3 in 4.3
and is not considerate enough to avoid bombing out
if they are already defined. */
#undef BSD
#ifdef BSD4_3
#undef BSD4_3
#define XBSD4_3 /* XBSD4_3 says BSD4_3 is supposed to be defined. */
#endif
#include <sys/param.h>
/* Now if BSD or BSD4_3 was defined and is no longer,
define it again. */
#ifndef BSD
#define BSD
#endif
#ifdef XBSD4_3
#ifndef BSD4_3
#define BSD4_3
#endif
#endif /* XBSD4_3 */
#endif /* BSD */
#ifndef VMS
#ifndef NLIST_STRUCT
#include <a.out.h>
#else /* NLIST_STRUCT */
#include <nlist.h>
#endif /* NLIST_STRUCT */
#endif /* not VMS */
#endif /* LOAD_AVE_TYPE */
/* Note on some machines this defines `vector' as a typedef,
so make sure we don't use that name in this file. */
#undef vector
#define vector *****
#ifdef NULL
#undef NULL
#endif
#include "lisp.h"
#include "commands.h"
#ifdef MULTI_SCREEN
#include "screen.h"
#endif
#include "buffer.h"
Lisp_Object Qstring_lessp;
DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
"Return the argument unchanged.")
(arg)
Lisp_Object arg;
{
return arg;
}
DEFUN ("random", Frandom, Srandom, 0, 1, 0,
"Return a pseudo-random number.\n\
On most systems all integers representable in Lisp are equally likely.\n\
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;
{
int val;
extern long random ();
extern srandom ();
extern long time ();
if (EQ (arg, Qt))
srandom (getpid () + time (0));
val = random ();
if (XTYPE (arg) == Lisp_Int && XINT (arg) != 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);
}
return make_number (val);
}
/* Random data-structure functions */
DEFUN ("length", Flength, Slength, 1, 1, 0,
"Return the length of vector, list or string SEQUENCE.\n\
A byte-code function object is also allowed.")
(obj)
register Lisp_Object obj;
{
register Lisp_Object tail, val;
register int i;
retry:
if (XTYPE (obj) == Lisp_Vector || XTYPE (obj) == Lisp_String
|| XTYPE (obj) == Lisp_Compiled)
return Farray_length (obj);
else if (CONSP (obj))
{
for (i = 0, tail = obj; !NULL(tail); i++)
{
QUIT;
tail = Fcdr (tail);
}
XFASTINT (val) = i;
return val;
}
else if (NULL(obj))
{
XFASTINT (val) = 0;
return val;
}
else
{
obj = wrong_type_argument (Qsequencep, obj);
goto retry;
}
}
DEFUN ("string-equal", Fstring_equal, Sstring_equal, 2, 2, 0,
"T if two strings have identical contents.\n\
Case is significant.\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);
CHECK_STRING (s1, 0);
CHECK_STRING (s2, 1);
if (XSTRING (s1)->size != XSTRING (s2)->size ||
bcmp (XSTRING (s1)->data, XSTRING (s2)->data, XSTRING (s1)->size))
return Qnil;
return Qt;
}
DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0,
"T if first arg string is less than second in lexicographic order.\n\
Case is significant.\n\
Symbols are also allowed; their print names are used instead.")
(s1, s2)
register Lisp_Object s1, s2;
{
register int i;
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);
CHECK_STRING (s1, 0);
CHECK_STRING (s2, 1);
p1 = XSTRING (s1)->data;
p2 = XSTRING (s2)->data;
end = XSTRING (s1)->size;
if (end > XSTRING (s2)->size)
end = XSTRING (s2)->size;
for (i = 0; i < end; i++)
{
if (p1[i] != p2[i])
return p1[i] < p2[i] ? Qt : Qnil;
}
return i < XSTRING (s2)->size ? Qt : Qnil;
}
static Lisp_Object concat ();
/* ARGSUSED */
Lisp_Object
concat2 (s1, s2)
Lisp_Object s1, s2;
{
#ifdef NO_ARG_ARRAY
Lisp_Object args[2];
args[0] = s1;
args[1] = s2;
return concat (2, args, Lisp_String, 0);
#else
return concat (2, &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\
Each argument may be a list, vector or string.\n\
The last argument is not copied if it is a list.")
(nargs, args)
int nargs;
Lisp_Object *args;
{
return concat (nargs, args, Lisp_Cons, 1);
}
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.")
(nargs, args)
int nargs;
Lisp_Object *args;
{
return concat (nargs, args, Lisp_String, 0);
}
DEFUN ("vconcat", Fvconcat, Svconcat, 0, MANY, 0,
"Concatenate all the arguments and make the result a vector.\n\
The result is a vector whose elements are the elements of all the arguments.\n\
Each argument may be a list, vector or string.")
(nargs, args)
int nargs;
Lisp_Object *args;
{
return concat (nargs, args, Lisp_Vector, 0);
}
DEFUN ("copy-sequence", Fcopy_sequence, Scopy_sequence, 1, 1, 0,
"Return a copy of a list, vector or string.\n\
The elements of a list or vector are not copied; they are shared\n\
with the original.")
(arg)
Lisp_Object arg;
{
if (NULL (arg)) return arg;
if (!CONSP (arg) && XTYPE (arg) != Lisp_Vector && XTYPE (arg) != Lisp_String)
arg = wrong_type_argument (Qsequencep, arg);
return concat (1, &arg, CONSP (arg) ? Lisp_Cons : XTYPE (arg), 0);
}
static Lisp_Object
concat (nargs, args, target_type, last_special)
int nargs;
Lisp_Object *args;
enum Lisp_Type target_type;
int last_special;
{
Lisp_Object val;
Lisp_Object len;
register Lisp_Object tail;
register Lisp_Object this;
int toindex;
register int leni;
register int argnum;
Lisp_Object last_tail;
Lisp_Object prev;
/* In append, the last arg isn't treated like the others */
if (last_special && nargs > 0)
{
nargs--;
last_tail = args[nargs];
}
else
last_tail = Qnil;
for (argnum = 0; argnum < nargs; argnum++)
{
this = args[argnum];
if (!(CONSP (this) || NULL (this)
|| XTYPE (this) == Lisp_Vector || XTYPE (this) == Lisp_String
|| XTYPE (this) == Lisp_Compiled))
{
if (XTYPE (this) == Lisp_Int)
args[argnum] = Fint_to_string (this);
else
args[argnum] = wrong_type_argument (Qsequencep, this);
}
}
for (argnum = 0, leni = 0; argnum < nargs; argnum++)
{
this = args[argnum];
len = Flength (this);
leni += XFASTINT (len);
}
XFASTINT (len) = leni;
if (target_type == Lisp_Cons)
val = Fmake_list (len, Qnil);
else if (target_type == Lisp_Vector)
val = Fmake_vector (len, Qnil);
else
val = Fmake_string (len, len);
/* In append, if all but last arg are nil, return last arg */
if (target_type == Lisp_Cons && EQ (val, Qnil))
return last_tail;
if (CONSP (val))
tail = val, toindex = -1; /* -1 in toindex is flag we are making a list */
else
toindex = 0;
prev = Qnil;
for (argnum = 0; argnum < nargs; argnum++)
{
Lisp_Object thislen;
int thisleni;
register int thisindex = 0;
this = args[argnum];
if (!CONSP (this))
thislen = Flength (this), thisleni = XINT (thislen);
while (1)
{
register Lisp_Object elt;
/* Fetch next element of `this' arg into `elt', or break if `this' is exhausted. */
if (NULL (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++];
else
elt = XVECTOR (this)->contents[thisindex++];
}
/* Store into result */
if (toindex < 0)
{
XCONS (tail)->car = elt;
prev = tail;
tail = XCONS (tail)->cdr;
}
else if (XTYPE (val) == Lisp_Vector)
XVECTOR (val)->contents[toindex++] = elt;
else
{
while (XTYPE (elt) != Lisp_Int)
elt = wrong_type_argument (Qintegerp, elt);
{
#ifdef MASSC_REGISTER_BUG
/* Even removing all "register"s doesn't disable this bug!
Nothing simpler than this seems to work. */
unsigned char *p = & XSTRING (val)->data[toindex++];
*p = XINT (elt);
#else
XSTRING (val)->data[toindex++] = XINT (elt);
#endif
}
}
}
}
if (!NULL (prev))
XCONS (prev)->cdr = last_tail;
return val;
}
DEFUN ("copy-alist", Fcopy_alist, Scopy_alist, 1, 1, 0,
"Return a copy of ALIST.\n\
This is an alist which represents the same mapping from objects to objects,\n\
but does not share the alist structure with ALIST.\n\
The objects mapped (cars and cdrs of elements of the alist)\n\
are shared, however.\n\
Elements of ALIST that are not conses are also shared.")
(alist)
Lisp_Object alist;
{
register Lisp_Object tem;
CHECK_LIST (alist, 0);
if (NULL (alist))
return alist;
alist = concat (1, &alist, Lisp_Cons, 0);
for (tem = alist; CONSP (tem); tem = XCONS (tem)->cdr)
{
register Lisp_Object car;
car = XCONS (tem)->car;
if (CONSP (car))
XCONS (tem)->car = Fcons (XCONS (car)->car, XCONS (car)->cdr);
}
return alist;
}
DEFUN ("substring", Fsubstring, Ssubstring, 2, 3, 0,
"Return a substring of STRING, starting at index FROM and ending before TO.\n\
TO may be nil or omitted; then the substring runs to the end of STRING.\n\
If FROM or TO is negative, it counts from the end.")
(string, from, to)
Lisp_Object string;
register Lisp_Object from, to;
{
CHECK_STRING (string, 0);
CHECK_NUMBER (from, 1);
if (NULL (to))
to = Flength (string);
else
CHECK_NUMBER (to, 2);
if (XINT (from) < 0)
XSETINT (from, XINT (from) + XSTRING (string)->size);
if (XINT (to) < 0)
XSETINT (to, XINT (to) + XSTRING (string)->size);
if (!(0 <= XINT (from) && XINT (from) <= XINT (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));
}
DEFUN ("nthcdr", Fnthcdr, Snthcdr, 2, 2, 0,
"Take cdr N times on LIST, returns the result.")
(n, list)
Lisp_Object n;
register Lisp_Object list;
{
register int i, num;
CHECK_NUMBER (n, 0);
num = XINT (n);
for (i = 0; i < num && !NULL (list); i++)
{
QUIT;
list = Fcdr (list);
}
return list;
}
DEFUN ("nth", Fnth, Snth, 2, 2, 0,
"Return the Nth element of LIST.\n\
N counts from zero. If LIST is not that long, nil is returned.")
(n, list)
Lisp_Object n, list;
{
return Fcar (Fnthcdr (n, list));
}
DEFUN ("elt", Felt, Selt, 2, 2, 0,
"Return element of SEQUENCE at index N.")
(seq, n)
register Lisp_Object seq, n;
{
CHECK_NUMBER (n, 0);
while (1)
{
if (XTYPE (seq) == Lisp_Cons || NULL (seq))
return Fcar (Fnthcdr (n, seq));
else if (XTYPE (seq) == Lisp_String ||
XTYPE (seq) == Lisp_Vector)
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\
The value is actually the tail of LIST whose car is ELT.")
(elt, list)
register Lisp_Object elt;
Lisp_Object list;
{
register Lisp_Object tail;
for (tail = list; !NULL (tail); tail = Fcdr (tail))
{
register Lisp_Object tem;
tem = Fcar (tail);
if (! NULL (Fequal (elt, tem)))
return tail;
QUIT;
}
return Qnil;
}
DEFUN ("memq", Fmemq, Smemq, 2, 2, 0,
"Return non-nil if ELT is an element of LIST. Comparison done with EQ.\n\
The value is actually the tail of LIST whose car is ELT.")
(elt, list)
register Lisp_Object elt;
Lisp_Object list;
{
register Lisp_Object tail;
for (tail = list; !NULL (tail); tail = Fcdr (tail))
{
register Lisp_Object tem;
tem = Fcar (tail);
if (EQ (elt, tem)) return tail;
QUIT;
}
return Qnil;
}
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\
Elements of LIST that are not conses are ignored.")
(key, list)
register Lisp_Object key;
Lisp_Object list;
{
register Lisp_Object tail;
for (tail = list; !NULL (tail); tail = Fcdr (tail))
{
register Lisp_Object elt, tem;
elt = Fcar (tail);
if (!CONSP (elt)) continue;
tem = Fcar (elt);
if (EQ (key, tem)) return elt;
QUIT;
}
return Qnil;
}
/* Like Fassq but never report an error and do not allow quits.
Use only on lists known never to be circular. */
Lisp_Object
assq_no_quit (key, list)
register Lisp_Object key;
Lisp_Object list;
{
register Lisp_Object tail;
for (tail = list; CONSP (tail); tail = Fcdr (tail))
{
register Lisp_Object elt, tem;
elt = Fcar (tail);
if (!CONSP (elt)) continue;
tem = Fcar (elt);
if (EQ (key, tem)) return elt;
}
return Qnil;
}
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.")
(key, list)
register Lisp_Object key;
Lisp_Object list;
{
register Lisp_Object tail;
for (tail = list; !NULL (tail); tail = Fcdr (tail))
{
register Lisp_Object elt, tem;
elt = Fcar (tail);
if (!CONSP (elt)) continue;
tem = Fequal (Fcar (elt), key);
if (!NULL (tem)) return elt;
QUIT;
}
return Qnil;
}
DEFUN ("rassq", Frassq, Srassq, 2, 2, 0,
"Return non-nil if ELT is `eq' to the cdr of an element of LIST.\n\
The value is actually the element of LIST whose cdr is ELT.")
(key, list)
register Lisp_Object key;
Lisp_Object list;
{
register Lisp_Object tail;
for (tail = list; !NULL (tail); tail = Fcdr (tail))
{
register Lisp_Object elt, tem;
elt = Fcar (tail);
if (!CONSP (elt)) continue;
tem = Fcdr (elt);
if (EQ (key, tem)) return elt;
QUIT;
}
return Qnil;
}
DEFUN ("delq", Fdelq, Sdelq, 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 `eq'.\n\
If the first member of LIST is ELT, there is no way to remove it by side effect;\n\
therefore, write `(setq foo (delq element foo))'\n\
to be sure of changing the value of `foo'.")
(elt, list)
register Lisp_Object elt;
Lisp_Object list;
{
register Lisp_Object tail, prev;
register Lisp_Object tem;
tail = list;
prev = Qnil;
while (!NULL (tail))
{
tem = Fcar (tail);
if (EQ (elt, tem))
{
if (NULL (prev))
list = Fcdr (tail);
else
Fsetcdr (prev, Fcdr (tail));
}
else
prev = tail;
tail = Fcdr (tail