This is fns.c in view mode; [Download] [Up]
/* Random utility Lisp functions.
Copyright (C) 1985-1987, 1992-1994 Free Software Foundation, Inc.
Copyright (C) 1994, 1995 Amdahl Corporation.
This file is part of XEmacs.
XEmacs 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 2, or (at your option) any
later version.
XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free
Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
/* Synched up with: Mule 2.0, FSF 19.28. */
/* This file has been Mule-ized except as noted. */
/* Hacked on for Mule by Ben Wing, December 1994, January 1995. */
#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. */
#undef vector
#define vector *****
#include "lisp.h"
#include "bytecode.h"
#include "buffer.h"
#include "commands.h"
#include "device.h"
#include "events.h"
#include "extents.h"
#include "frame.h"
#include "systime.h"
Lisp_Object Qstring_lessp;
Lisp_Object Qidentity;
DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0,
"Return the argument unchanged.")
(arg)
Lisp_Object arg;
{
return arg;
}
/* Let's assume that those systems that have random() also have it
prototyped. If not, fix it in the appropriate s/ file. */
#ifndef HAVE_RANDOM
/* Under linux with gcc -O, these are macros. Do not declare. */
#ifndef random
extern long random (void);
#endif
#ifndef srandom
extern void srandom (int arg);
#endif
#endif /* HAVE_RANDOM */
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\
A lisp integer is a few bits smaller than a C `long'; on most systems,\n\
this means 28 bits.)\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.")
(limit)
Lisp_Object limit;
{
int val;
if (EQ (limit, Qt))
srandom (getpid () + time (0));
if (INTP (limit) && XINT (limit) > 0)
{
if (XINT (limit) >= 0x40000000)
/* This case may occur on 64-bit machines. */
val = random () % XINT (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. */
unsigned long denominator = (unsigned long)0x40000000 / XINT (limit);
do
val = (random () & 0x3fffffff) / denominator;
while (val >= XINT (limit));
}
}
else
val = random ();
return make_number (val);
}
/* Random data-structure functions */
/* Charcount is a misnomer here as we might be dealing with the
length of a vector or list, but emphasizes that we're not dealing
with Bytecounts in strings */
static Charcount
length_with_bytecode_hack (Lisp_Object seq)
{
if (!BYTECODEP (seq))
return (XINT (Flength (seq)));
else
{
struct Lisp_Bytecode *b = XBYTECODE (seq);
int intp = b->flags.interactivep;
int domainp = b->flags.domainp;
if (intp)
return (COMPILED_INTERACTIVE + 1);
else if (domainp)
return (COMPILED_DOMAIN + 1);
else
return (COMPILED_DOC_STRING + 1);
}
}
DEFUN ("length", Flength, Slength, 1, 1, 0,
"Return the length of vector, list or string SEQUENCE.")
(obj)
Lisp_Object obj;
{
Lisp_Object tail;
int i;
retry:
if (STRINGP (obj))
return (make_number (string_char_length (XSTRING (obj))));
else if (VECTORP (obj))
return (make_number (vector_length (XVECTOR (obj))));
else if (CONSP (obj))
{
for (i = 0, tail = obj; !NILP (tail); i++)
{
QUIT;
tail = Fcdr (tail);
}
return (make_number (i));
}
else if (NILP (obj))
{
return (Qzero);
}
#if 0 /* I don't see any need to make this "work" */
/* revolting "concat" callers use "length_with_bytecode_hack",
* so that bytecomp.el (which uses "(append bytcode nil)"
* "works". */
else if (COMPILED (obj))
...
#endif /* 0 */
else
{
obj = wrong_type_argument (Qsequencep, obj);
goto retry;
}
}
/*** string functions. ***/
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)
Lisp_Object s1, s2;
{
int len;
if (SYMBOLP (s1))
XSETSTRING (s1, XSYMBOL (s1)->name);
if (SYMBOLP (s2))
XSETSTRING (s2, XSYMBOL (s2)->name);
CHECK_STRING (s1, 0);
CHECK_STRING (s2, 1);
len = string_length (XSTRING (s1));
if (len != string_length (XSTRING (s2)) ||
memcmp (string_data (XSTRING (s1)), string_data (XSTRING (s2)), len))
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\
If I18N2 support was compiled in, ordering is determined by the locale.\n\
Case is significant for the default C locale.\n\
Symbols are also allowed; their print names are used instead.")
(s1, s2)
Lisp_Object s1, s2;
{
/* !!#### This function has not been Mule-ized. */
struct Lisp_String *p1, *p2;
Charcount end, len2;
if (SYMBOLP (s1))
XSETSTRING (s1, XSYMBOL (s1)->name);
if (SYMBOLP (s2))
XSETSTRING (s2, XSYMBOL (s2)->name);
CHECK_STRING (s1, 0);
CHECK_STRING (s2, 1);
p1 = XSTRING (s1);
p2 = XSTRING (s2);
end = string_char_length (XSTRING (s1));
len2 = string_char_length (XSTRING (s2));
if (end > len2)
end = len2;
{
int i;
#ifdef I18N2
Bytecount bcend = charcount_to_bytecount (string_data (p1), end);
/* Compare strings using collation order of locale. */
/* Need to be tricky to handle embedded nulls. */
for (i = 0; i < bcend; i += strlen((char *) string_data (p1) + i) + 1)
{
int val = strcoll ((char *) string_data (p1) + i,
(char *) string_data (p2) + i);
if (val < 0)
return Qt;
if (val > 0)
return Qnil;
}
#else /* not I18N2 */
for (i = 0; i < end; i++)
{
if (string_char (p1, i) != string_char (p2, i))
return string_char (p1, i) < string_char (p2, i) ? Qt : Qnil;
}
#endif /* not I18N2 */
/* Can't do i < len2 because then comparison between "foo" and "foo^@"
won't work right in I18N2 case */
return ((end < len2) ? Qt : Qnil);
}
}
DEFUN ("string-modified-tick", Fstring_modified_tick, Sstring_modified_tick,
1, 1, 0,
"Return STRING's tick counter, incremented for each change to the string.\n\
Each string has a tick counter which is incremented each time the contents\n\
of the string are changed (e.g. with `aset'). It wraps around occasionally.")
(string)
Lisp_Object string;
{
struct Lisp_String *s;
CHECK_STRING (string, 0);
s = XSTRING (string);
if (CONSP (s->plist) && INTP (XCAR (s->plist)))
return XCAR (s->plist);
else
return Qzero;
}
void
bump_string_modiff (Lisp_Object str)
{
struct Lisp_String *s = XSTRING (str);
#ifdef I18N3
/* #### remove the `string-translatable' property from the string,
if there is one. */
#endif
if (CONSP (s->plist) && INTP (XCAR (s->plist)))
XSETINT (XCAR (s->plist), 1+XINT (XCAR (s->plist)));
else
s->plist = Fcons (make_number (1), s->plist);
}
enum concat_target_type { c_cons, c_string, c_vector };
static Lisp_Object concat (int nargs, Lisp_Object *args,
enum concat_target_type target_type,
int last_special);
Lisp_Object
concat2 (Lisp_Object s1, Lisp_Object s2)
{
Lisp_Object args[2];
args[0] = s1;
args[1] = s2;
return concat (2, args, c_string, 0);
}
Lisp_Object
vconcat2 (Lisp_Object s1, Lisp_Object s2)
{
Lisp_Object args[2];
args[0] = s1;
args[1] = s2;
return concat (2, args, c_vector, 0);
}
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, just used as the tail of the new list.")
(nargs, args)
int nargs;
Lisp_Object *args;
{
return concat (nargs, args, c_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 character (integer), a list of characters,\n\
or a vector of numbers.")
(nargs, args)
int nargs;
Lisp_Object *args;
{
return concat (nargs, args, c_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, c_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;
{
again:
if (NILP (arg)) return arg;
/* We handle conses separately because concat() is big and hairy and
doesn't handle (copy-sequence '(a b . c)) and it's easier to redo this
than to fix concat() without worrying about breaking other things.
*/
if (CONSP (arg))
{
Lisp_Object rest = arg;
Lisp_Object head, tail;
tail = Qnil;
while (CONSP (rest))
{
Lisp_Object new = Fcons (XCAR (rest), XCDR (rest));
if (NILP (tail))
head = tail = new;
else
XCDR (tail) = new, tail = new;
rest = XCDR (rest);
QUIT;
}
if (!NILP (tail))
XCDR (tail) = rest;
return head;
}
else if (STRINGP (arg))
return concat (1, &arg, c_string, 0);
else if (VECTORP (arg))
return concat (1, &arg, c_vector, 0);
else
{
arg = wrong_type_argument (Qsequencep, arg);
goto again;
}
}
static Lisp_Object
concat (int nargs, Lisp_Object *args,
enum concat_target_type target_type,
int last_special)
{
Lisp_Object val;
Lisp_Object tail = Qnil;
int toindex;
int argnum;
Lisp_Object last_tail;
Lisp_Object prev;
struct merge_replicas_struct *args_mr = 0;
struct gcpro gcpro1;
/* The modus operandi in Emacs is "caller gc-protects args".
However, concat is called many times in Emacs on freshly
created stuff. So we help those callers out by protecting
the args ourselves to save them a lot of temporary-variable
grief. */
GCPRO1 (args[0]);
gcpro1.nvars = nargs;
#ifdef I18N3
/* #### if the result is a string and any of the strings have a string
for the `string-translatable' property, then concat should also
concat the args but use the `string-translatable' strings, and store
the result in the returned string's `string-translatable' property. */
#endif
if (target_type == c_string)
{
int size = nargs * sizeof (struct merge_replicas_struct);
args_mr = (struct merge_replicas_struct *) alloca (size);
}
/* 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;
/* Check and coerce the arguments. */
for (argnum = 0; argnum < nargs; argnum++)
{
Lisp_Object seq = args[argnum];
if (CONSP (seq) || NILP (seq))
;
else if (VECTORP (seq) || STRINGP (seq))
;
else if (BYTECODEP (seq))
/* Urk! We allow this, for "compatibility"... */
;
else if (INTP (seq))
/* This is too revolting to think about but maintains
compatibility with FSF (and lots and lots of old code). */
args[argnum] = Fnumber_to_string (seq);
else
args[argnum] = wrong_type_argument (Qsequencep, seq);
if (args_mr)
{
if (STRINGP (seq))
args_mr[argnum].dup_list = string_dups (XSTRING (seq));
else
args_mr[argnum].dup_list = Qnil;
}
}
{
/* Charcount is a misnomer here as we might be dealing with the
length of a vector or list, but emphasizes that we're not dealing
with Bytecounts in strings */
Charcount total_length;
for (argnum = 0, total_length = 0; argnum < nargs; argnum++)
{
Charcount thislen = length_with_bytecode_hack (args[argnum]);
if (args_mr)
{
args_mr[argnum].entry_offset = total_length;
args_mr[argnum].entry_length = thislen;
}
total_length += thislen;
}
switch (target_type)
{
case c_cons:
if (total_length == 0)
/* In append, if all but last arg are nil, return last arg */
RETURN_UNGCPRO (last_tail);
val = Fmake_list (make_number (total_length), Qnil);
break;
case c_vector:
val = make_vector (total_length, Qnil);
break;
case c_string:
val = Fmake_string (make_number (total_length), Qzero);
set_string_dups (XSTRING (val), merge_replicas (nargs, args_mr));
break;
default:
abort ();
}
}
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++)
{
Charcount thisleni = 0;
Charcount thisindex = 0;
Lisp_Object seq = args[argnum];
if (!CONSP (seq))
{
thisleni = length_with_bytecode_hack (seq);
}
while (1)
{
Lisp_Object elt;
/* We've come to the end of this arg, so exit. */
if (NILP (seq))
break;
/* Fetch next element of `seq' arg into `elt' */
if (CONSP (seq))
{
elt = Fcar (seq);
seq = Fcdr (seq);
}
else
{
if (thisindex >= thisleni)
break;
if (STRINGP (seq))
elt = make_number (string_char (XSTRING (seq), thisindex));
else if (VECTORP (seq))
elt = vector_data (XVECTOR (seq))[thisindex];
else
elt = Felt (seq, make_number (thisindex));
thisindex++;
}
/* Store into result */
if (toindex < 0)
{
/* toindex negative means we are making a list */
XCAR (tail) = elt;
prev = tail;
tail = XCDR (tail);
}
else if (VECTORP (val))
vector_data (XVECTOR (val))[toindex++] = elt;
else
{
while (!INTP (elt))
elt = wrong_type_argument (Qintegerp, elt);
{
#ifdef MASSC_REGISTER_BUG
you lose -- fix this code up!
/* Even removing all "register"s doesn't disable this bug!
Nothing simpler than this seems to work. */
unsigned char *p =
& string_char_address_of (XSTRING (val), toindex++);
*p = XINT (elt);
#else
set_string_char (XSTRING (val), toindex++, XINT (elt));
#endif
}
}
}
}
if (!NILP (prev))
XCDR (prev) = last_tail;
RETURN_UNGCPRO (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;
{
Lisp_Object tem;
CHECK_LIST (alist, 0);
if (NILP (alist))
return alist;
alist = concat (1, &alist, c_cons, 0);
for (tem = alist; CONSP (tem); tem = XCDR (tem))
{
Lisp_Object car;
car = XCAR (tem);
if (CONSP (car))
XCAR (tem) = Fcons (XCAR (car), XCDR (car));
}
return alist;
}
DEFUN ("copy-tree", Fcopy_tree, Scopy_tree, 1, 2, 0,
"Return a copy of a list and substructures.\n\
The argument is copied, and any lists contained within it are copied\n\
recursively. Circularities and shared substructures are not preserved.\n\
Second arg VECP causes vectors to be copied, too. Strings are not copied.")
(arg, vecp)
Lisp_Object arg, vecp;
{
if (CONSP (arg))
{
Lisp_Object rest;
rest = arg = Fcopy_sequence (arg);
while (CONSP (rest))
{
Lisp_Object elt = XCAR (rest);
QUIT;
if (CONSP (elt) || VECTORP (elt))
XCAR (rest) = Fcopy_tree (elt, vecp);
if (VECTORP (XCDR (rest))) /* hack for (a b . [c d]) */
XCDR (rest) = Fcopy_tree (XCDR (rest), vecp);
rest = XCDR (rest);
}
}
else if (VECTORP (arg) && ! NILP (vecp))
{
int i = vector_length (XVECTOR (arg));
int j;
arg = Fcopy_sequence (arg);
for (j = 0; j < i; j++)
{
Lisp_Object elt = vector_data (XVECTOR (arg)) [j];
QUIT;
if (CONSP (elt) || VECTORP (elt))
vector_data (XVECTOR (arg)) [j] = Fcopy_tree (elt, vecp);
}
}
return arg;
}
Bytecount
get_string_range (Lisp_Object string, Lisp_Object from, Lisp_Object to,
Bytecount *from_out, Bytecount *to_out)
{
Charcount len;
Charcount from1, to1;
CHECK_STRING (string, 0);
len = string_char_length (XSTRING (string));
if (NILP (from))
from1 = 0;
else
{
CHECK_INT (from, 1);
from1 = XINT (from);
}
if (NILP (to))
to1 = len;
else
{
CHECK_INT (to, 2);
to1 = XINT (to);
}
if (from1 < 0)
from1 = from1 + len;
if (to1 < 0)
to1 = to1 + len;
if (!(0 <= from1 && from1 <= to1 && to1 <= len))
args_out_of_range_3 (string, make_number (from1), make_number (to1));
*from_out = charcount_to_bytecount (string_data (XSTRING (string)), from1);
*to_out = charcount_to_bytecount (string_data (XSTRING (string)), to1);
return (*to_out - *from_out);
}
Bytecount
get_string_bytepos (Lisp_Object string, Lisp_Object pos)
{
Charcount ccpos;
CHECK_STRING (string, 0);
CHECK_INT (pos, 1);
ccpos = XINT (pos);
if (ccpos < 0 || ccpos > string_char_length (XSTRING (string)))
args_out_of_range (string, pos);
return charcount_to_bytecount (string_data (XSTRING (string)), ccpos);
}
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.\n\
Relevant parts of the string-extent-data are copied in the new string.")
(string, from, to)
Lisp_Object string;
Lisp_Object from, to;
{
Bytecount bfr, bto;
Bytecount len;
Lisp_Object val;
/* Historically, FROM could not be omitted. Whatever ... */
CHECK_INT (from, 1);
len = get_string_range (string, from, to, &bfr, &bto);
val = make_string (string_data (XSTRING (string)) + bfr, len);
/* Copy any applicable extent information into the new string: */
if (!NILP (string_dups (XSTRING (string))))
set_string_dups (XSTRING (val),
shift_replicas (string_dups (XSTRING (string)),
- bfr, len));
return (val);
}
DEFUN ("nthcdr", Fnthcdr, Snthcdr, 2, 2, 0,
"Take cdr N times on LIST, returns the result.")
(n, list)
Lisp_Object n;
Lisp_Object list;
{
REGISTER int i, num;
CHECK_INT (n, 0);
num = XINT (n);
for (i = 0; i < num && !NILP (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)
Lisp_Object seq, n;
{
retry:
CHECK_INT (n, 0);
if (CONSP (seq) || NILP (seq))
{
Lisp_Object tem = Fnthcdr (n, seq);
/* #### Utterly, completely, fucking disgusting.
* #### The whole point of "elt" is that it operates on
* #### sequences, and does error- (bounds-) checking.
*/
if (CONSP (tem))
return (XCAR (tem));
else
#if 1
/* This is The Way It Has Always Been. */
return Qnil;
#else
/* This is The Way Mly Says It Should Be. */
args_out_of_range (seq, n);
#endif
}
else if (STRINGP (seq)
|| VECTORP (seq))
return (Faref (seq, n));
else if (BYTECODEP (seq))
{
int idx = XINT (n);
if (idx < 0)
{
lose:
args_out_of_range (seq, n);
}
/* Utter perversity */
{
struct Lisp_Bytecode *b = XBYTECODE (seq);
switch (idx)
{
case COMPILED_ARGLIST:
return (b->arglist);
case COMPILED_BYTECODE:
return (b->bytecodes);
case COMPILED_CONSTANTS:
return (b->constants);
case COMPILED_STACK_DEPTH:
return (make_number (b->maxdepth));
case COMPILED_DOC_STRING:
return (bytecode_documentation (b));
case COMPILED_DOMAIN:
return (bytecode_domain (b));
case COMPILED_INTERACTIVE:
if (b->flags.interactivep)
return (bytecode_interactive (b));
/* if we return nil, can't tell interactive with no args
from noninteractive. */
goto lose;
default:
goto lose;
}
}
}
else
{
seq = wrong_type_argument (Qsequencep, seq);
goto retry;
}
}
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)
Lisp_Object elt;
Lisp_Object list;
{
REGISTER Lisp_Object tail, tem;
for (tail = list; !NILP (tail); tail = Fcdr (tail))
{
tem = Fcar (tail);
if (! NILP (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)
Lisp_Object elt;
Lisp_Object list;
{
REGISTER Lisp_Object tail, tem;
for (tail = list; !NILP (tail); tail = Fcdr (tail))
{
tem = Fcar (tail);
if (EQ (elt, tem)) return tail;
QUIT;
}
return Qnil;
}
Lisp_Object
memq_no_quit (Lisp_Object elt, Lisp_Object list)
{
REGISTER Lisp_Object tail, tem;
for (tail = list; CONSP (tail); tail = XCDR (tail))
{
tem = XCAR (tail);
if (EQ (elt, tem)) return tail;
}
return Qnil;
}
DEFUN ("assoc", Fassoc, Sassoc, 2, 2, 0,
"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)
Lisp_Object key;
Lisp_Object list;
{
REGISTER Lisp_Object tail, elt, tem;
for (tail = list; !NILP (tail); tail = Fcdr (tail))
{
elt = Fcar (tail);
if (!CONSP (elt)) continue;
tem = Fequal (Fcar (elt), key);
if (!NILP (tem)) return elt;
QUIT;
}
return Qnil;
}
Lisp_Object
assoc_no_quit (Lisp_Object key, Lisp_Object list)
{
int speccount = specpdl_depth ();
specbind (Qinhibit_quit, Qt);
return (unbind_to (speccount, Fassoc (key, list)));
}
DEFUN ("assq", Fassq, Sassq, 2, 2, 0,
"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)
Lisp_Object key;
Lisp_Object list;
{
/* This function can GC. */
REGISTER Lisp_Object tail, elt, tem;
for (tail = list; !NILP (tail); tail = Fcdr (tail))
{
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 (Lisp_Object key, Lisp_Object list)
{
/* This cannot GC. */
REGISTER Lisp_Object tail, elt, tem;
for (tail = list; CONSP (tail); tail = XCDR (tail))
{
elt = XCAR (tail);
if (!CONSP (elt)) continue;
tem = XCAR (elt);
if (EQ (key, tem)) return elt;
}
return Qnil;
}
DEFUN ("rassoc", Frassoc, Srassoc, 2, 2, 0,
"Return non-nil if KEY is `equal' to the cdr of an element of LIST.\n\
The value is actually the element of LIST whose cdr is KEY.")
(key, list)
Lisp_Object key;
Lisp_Object list;
{
REGISTER Lisp_Object tail, elt, tem;
for (tail = list; !NILP (tail); tail = Fcdr (tail))
{
elt = Fcar (tail);
if (!CONSP (elt)) continue;
tem = Fequal (Fcdr (elt), key);
if (!NILP (tem)) return elt;
QUIT;
}
return Qnil;
}
DEFUN ("rassq", Frassq, Srassq, 2, 2, 0,
"Return non-nil if KEY is `eq' to the cdr of an element of LIST.\n\
The value is actually the element of LIST whose cdr is KEY.")
(key, list)
Lisp_Object key;
Lisp_Object list;
{
REGISTER Lisp_Object tail, elt, tem;
for (tail = list; !NILP (tail); tail = Fcdr (tail))
{
elt = Fcar (tail);
if (!CONSP (elt)) continue;
tem = Fcdr (elt);
if (EQ (key, tem)) return elt;
QUIT;
}
return Qnil;
}
Lisp_Object
rassq_no_quit (Lisp_Object key, Lisp_Object list)
{
REGISTER Lisp_Object tail, elt, tem;
for (tail = list; CONSP (tail); tail = XCDR (tail))
{
elt = XCAR (tail);
if (!CONSP (elt)) continue;
tem = XCDR (elt);
if (EQ (key, tem)) return elt;
}
return Qnil;
}
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\n\
effect; therefore, write `(setq foo (delete element foo))' to be sure\n\
of changing the value of `foo'.")
(elt, list)
Lisp_Object elt;
Lisp_Object list;
{
REGISTER Lisp_Object tail, prev;
tail = list;
prev = Qnil;
while (!NILP (tail))
{
if (! NILP (Fequal (elt, Fcar (tail))))
{
if (NILP (prev))
list = Fcdr (tail);
else
Fsetcdr (prev, Fcdr (tail));
}
else
prev = tail;
tail = Fcdr (tail);
QUIT;
}
return list;
}
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\n\
effect; therefore, write `(setq foo (delq element foo))' to be sure of\n\
changing the value of `foo'.")
(elt, list)
Lisp_Object elt;
Lisp_Object list;
{
REGISTER Lisp_Object tail, prev;
REGISTER Lisp_Object tem;
tail = list;
prev = Qnil;
while (!NILP (tail))
{
tem = Fcar (tail);
if (EQ (elt, tem))
{
if (NILP (prev))
list = Fcdr (tail);
else
Fsetcdr (prev, Fcdr (tail));
}
else
prev = tail;
tail = Fcdr (tail);
QUIT;
}
return list;
}
/* no quit, no errors; be careful */
Lisp_Object
delq_no_quit (Lisp_Object elt, Lisp_Object list)
{
REGISTER Lisp_Object tail, prev;
REGISTER Lisp_Object tem;
tail = list;
prev = Qnil;
while (CONSP (tail))
{
tem = XCAR (tail);
if (EQ (elt, tem))
{
if (NILP (prev))
list = XCDR (tail);
else
XCDR (prev) = XCDR (tail);
}
else
prev = tail;
tail = XCDR (tail);
}
return list;
}
DEFUN ("remassoc", Fremassoc, Sremassoc, 2, 2, 0,
"Delete by side effect any elements of LIST whose car is `equal' to KEY.\n\
The modified LIST is returned. If the first member of LIST has a car\n\
that is `equal' to KEY, there is no way to remove it by side effect;\n\
therefore, write `(setq foo (remassoc key foo))' to be sure of changing\n\
the value of `foo'.")
(key, list)
Lisp_Object key;
Lisp_Object list;
{
REGISTER Lisp_Object tail, prev;
tail = list;
prev = Qnil;
while (!NILP (tail))
{
Lisp_Object elt = Fcar (tail);
if (CONSP (elt) && ! NILP (Fequal (key, Fcar (elt))))
{
if (NILP (prev))
list = Fcdr (tail);
else
Fsetcdr (prev, Fcdr (tail));
}
else
prev = tail;
tail = Fcdr (tail);
QUIT;
}
return list;
}
Lisp_Object
remassoc_no_quit (Lisp_Object key, Lisp_Object list)
{
int speccount = specpdl_depth ();
specbind (Qinhibit_quit, Qt);
return (unbind_to (speccount, Fremassoc (key, list)));
}
DEFUN ("remassq", Fremassq, Sremassq, 2, 2, 0,
"Delete by side effect any elements of LIST whose car is `eq' to KEY.\n\
The modified LIST is returned. If the first member of LIST has a car\n\
that is `eq' to KEY, there is no way to remove it by side effect;\n\
therefore, write `(setq foo (remassq key foo))' to be sure of changing\n\
the value of `foo'.")
(key, list)
Lisp_Object key;
Lisp_Object list;
{
REGISTER Lisp_Object tail, prev;
tail = list;
prev = Qnil;
while (!NILP (tail))
{
Lisp_Object elt = Fcar (tail);
if (CONSP (elt) && EQ (key, Fcar (elt)))
{
if (NILP (prev))
list = Fcdr (tail);
else
Fsetcdr (prev, Fcdr (tail));
}
else
prev = tail;
tail = Fcdr (tail);
QUIT;
}
return list;
}
/* no quit, no errors; be careful */
Lisp_Object
remassq_no_quit (Lisp_Object key, Lisp_Object list)
{
REGISTER Lisp_Object tail, prev;
REGISTER Lisp_Object tem;
tail = list;
prev = Qnil;
while (CONSP (tail))
{
tem = XCAR (tail);
if (CONSP (tem) && EQ (key, XCAR (tem)))
{
if (NILP (prev))
list = XCDR (tail);
else
XCDR (prev) = XCDR (tail);
}
else
prev = tail;
tail = XCDR (tail);
}
return list;
}
DEFUN ("remrassoc", Fremrassoc, Sremrassoc, 2, 2, 0,
"Delete by side effect any elements of LIST whose cdr is `equal' to KEY.\n\
The modified LIST is returned. If the first member of LIST has a car\n\
that is `equal' to KEY, there is no way to remove it by side effect;\n\
therefore, write `(setq foo (remrassoc key foo))' to be sure of changing\n\
the value of `foo'.")
(key, list)
Lisp_Object key;
Lisp_Object list;
{
REGISTER Lisp_Object tail, prev;
tail = list;
prev = Qnil;
while (!NILP (tail))
{
Lisp_Object elt = Fcar (tail);
if (CONSP (elt) && ! NILP (Fequal (key, Fcdr (elt))))
{
if (NILP (prev))
list = Fcdr (tail);
else
Fsetcdr (prev, Fcdr (tail));
}
else
prev = tail;
tail = Fcdr (tail);
QUIT;
}
return list;
}
DEFUN ("remrassq", Fremrassq, Sremrassq, 2, 2, 0,
"Delete by side effect any elements of LIST whose cdr is `eq' to KEY.\n\
The modified LIST is returned. If the first member of LIST has a car\n\
that is `eq' to KEY, there is no way to remove it by side effect;\n\
therefore, write `(setq foo (remrassq key foo))' to be sure of changing\n\
the value of `foo'.")
(key, list)
Lisp_Object key;
Lisp_Object list;
{
REGISTER Lisp_Object tail, prev;
tail = list;
prev = Qnil;
while (!NILP (tail))
{
Lisp_Object elt = Fcar (tail);
if (CONSP (elt) && EQ (key, Fcdr (elt)))
{
if (NILP (prev))
list = Fcdr (tail);
else
Fsetcdr (prev, Fcdr (tail));
}
else
prev = tail;
tail = Fcdr (tail);
QUIT;
}
return list;
}
/* no quit, no errors; be careful */
Lisp_Object
remrassq_no_quit (Lisp_Object key, Lisp_Object list)
{
REGISTER Lisp_Object tail, prev;
REGISTER Lisp_Object tem;
tail = list;
prev = Qnil;
while (CONSP (tail))
{
tem = XCAR (tail);
if (CONSP (tem) && EQ (key, XCDR (tem)))
{
if (NILP (prev))
list = XCDR (tail);
else
XCDR (prev) = XCDR (tail);
}
else
prev = tail;
tail = XCDR (tail);
}
return list;
}
DEFUN ("nreverse", Fnreverse, Snreverse, 1, 1, 0,
"Reverse LIST by modifying cdr pointers.\n\
Returns the beginning of the reversed list.")
(list)
Lisp_Object list;
{
REGISTER Lisp_Object prev, tail, next;
prev = Qnil;
tail = list;
while (!NILP (tail))
{
QUIT;
next = Fcdr (tail);
Fsetcdr (tail, prev);
prev = tail;
tail = next;
}
return prev;
}
DEFUN ("reverse", Freverse, Sreverse, 1, 1, 0,
"Reverse LIST, copying. Returns the beginning of the reversed list.\n\
See also the function `nreverse', which is used more often.")
(list)
Lisp_Object list;
{
Lisp_Object length;
Lisp_Object *vec;
Lisp_Object tail;
REGISTER int i;
length = Flength (list);
vec = (Lisp_Object *) alloca (XINT (length) * sizeof (Lisp_Object));
for (i = XINT (length) - 1, tail = list; i >= 0; i--, tail = Fcdr (tail))
vec[i] = Fcar (tail);
return Flist (XINT (length), vec);
}
static Lisp_Object list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
Lisp_Object lisp_arg,
int (*pred_fn) (Lisp_Object, Lisp_Object,
Lisp_Object lisp_arg));
Lisp_Object
list_sort (Lisp_Object list,
Lisp_Object lisp_arg,
int (*pred_fn) (Lisp_Object, Lisp_Object,
Lisp_Object lisp_arg))
{
Lisp_Object front, back;
Lisp_Object len, tem;
struct gcpro gcpro1, gcpro2, gcpro3;
int length;
front = list;
len = Flength (list);
length = XINT (len);
if (length < 2)
return list;
XSETINT (len, (length / 2) - 1);
tem = Fnthcdr (len, list);
back = Fcdr (tem);
Fsetcdr (tem, Qnil);
GCPRO3 (front, back, lisp_arg);
front = list_sort (front, lisp_arg, pred_fn);
back = list_sort (back, lisp_arg, pred_fn);
UNGCPRO;
return list_merge (front, back, lisp_arg, pred_fn);
}
void
run_hook_with_args (Lisp_Object hook_var, int nargs, ...)
{
/* This function can GC */
Lisp_Object rest;
int i;
va_list vargs;
va_start (vargs, nargs);
if (NILP (Fboundp (hook_var)))
rest = Qnil;
else
rest = Fsymbol_value (hook_var);
if (NILP (rest))
{
/* Discard C's excuse for &rest */
for (i = 0; i < nargs; i++)
(void) va_arg (vargs, Lisp_Object);
va_end (vargs);
return;
}
else
{
struct gcpro gcpro1, gcpro2;
Lisp_Object *funcall_args =
(Lisp_Object *) alloca ((1 + nargs) * sizeof (Lisp_Object));
for (i = 0; i < nargs; i++)
funcall_args[i + 1] = va_arg (vargs, Lisp_Object);
va_end (vargs);
funcall_args[0] = rest;
GCPRO2 (rest, *funcall_args);
gcpro2.nvars = nargs + 1;
if (!CONSP (rest) || EQ (Qlambda, XCAR (rest)))
Ffuncall (nargs + 1, funcall_args);
else
{
while (!NILP (rest))
{
funcall_args[0] = Fcar (rest);
Ffuncall (nargs + 1, funcall_args);
rest = Fcdr (rest);
}
}
UNGCPRO;
}
}
static int
merge_pred_function (Lisp_Object obj1, Lisp_Object obj2,
Lisp_Object pred)
{
Lisp_Object tmp;
/* prevents the GC from happening in call2 */
int speccount = specpdl_depth ();
/* Emacs' GC doesn't actually relocate pointers, so this probably
isn't strictly necessary */
record_unwind_protect (restore_gc_inhibit,
make_number (gc_currently_forbidden));
gc_currently_forbidden = 1;
tmp = call2 (pred, obj1, obj2);
unbind_to (speccount, Qnil);
if (NILP (tmp))
return -1;
else
return 1;
}
DEFUN ("sort", Fsort, Ssort, 2, 2, 0,
"Sort LIST, stably, comparing elements using PREDICATE.\n\
Returns the sorted list. LIST is modified by side effects.\n\
PREDICATE is called with two elements of LIST, and should return T\n\
if the first element is \"less\" than the second.")
(list, pred)
Lisp_Object list, pred;
{
return list_sort (list, pred, merge_pred_function);
}
Lisp_Object
merge (Lisp_Object org_l1, Lisp_Object org_l2,
Lisp_Object pred)
{
return list_merge (org_l1, org_l2, pred, merge_pred_function);
}
static Lisp_Object
list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
Lisp_Object lisp_arg,
int (*pred_fn) (Lisp_Object, Lisp_Object, Lisp_Object lisp_arg))
{
Lisp_Object value;
Lisp_Object tail;
Lisp_Object tem;
Lisp_Object l1, l2;
struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
l1 = org_l1;
l2 = org_l2;
tail = Qnil;
value = Qnil;
/* It is sufficient to protect org_l1 and org_l2.
When l1 and l2 are updated, we copy the new values
back into the org_ vars. */
GCPRO4 (org_l1, org_l2, lisp_arg, value);
while (1)
{
if (NILP (l1))
{
UNGCPRO;
if (NILP (tail))
return l2;
Fsetcdr (tail, l2);
return value;
}
if (NILP (l2))
{
UNGCPRO;
if (NILP (tail))
return l1;
Fsetcdr (tail, l1);
return value;
}
if (((*pred_fn) (Fcar (l2), Fcar (l1), lisp_arg)) < 0)
{
tem = l1;
l1 = Fcdr (l1);
org_l1 = l1;
}
else
{
tem = l2;
l2 = Fcdr (l2);
org_l2 = l2;
}
if (NILP (tail))
value = tem;
else
Fsetcdr (tail, tem);
tail = tem;
}
}
/************************************************************************/
/* property-list functions */
/************************************************************************/
static void
check_plist_structure (Lisp_Object plist)
{
Lisp_Object rest;
for (rest = plist; !NILP (rest); rest = XCDR (XCDR (rest)))
{
QUIT; /* in case of circularities */
if (!CONSP (rest) || !SYMBOLP (XCAR (rest)) || !CONSP (XCDR (rest)))
error ("Invalid property list structure");
}
}
/* For properties of text, we need to do order-insensitive comparison of
plists. That is, we need to compare two plists such that they are the
same if they have the same set of keys with non-nil values, and equivalent
values. So (a 1 b 2 c nil) would be equal to (b 2 a 1).
*/
int
plists_differ (Lisp_Object a, Lisp_Object b, int depth)
{
int eqp = (depth == -1); /* -1 as depth means us eq, not equal. */
int la, lb, m, i, fill;
Lisp_Object *keys, *vals;
char *flags;
Lisp_Object rest;
if (NILP (a) && NILP (b))
return 0;
la = XINT (Flength (a));
lb = XINT (Flength (b));
m = (la > lb ? la : lb);
fill = 0;
keys = (Lisp_Object *) alloca (m * sizeof (Lisp_Object));
vals = (Lisp_Object *) alloca (m * sizeof (Lisp_Object));
flags = (char *) alloca (m * sizeof (char));
/* First extract the pairs from A whose value is not nil. */
for (rest = a; !NILP (rest); rest = XCDR (XCDR (rest)))
{
Lisp_Object k = XCAR (rest);
Lisp_Object v = XCAR (XCDR (rest));
if (NILP (v)) continue;
keys [fill] = k;
vals [fill] = v;
flags[fill] = 0;
fill++;
}
/* Now iterate over B, and stop if we find something that's not in A,
or that doesn't match. As we match, mark them. */
for (rest = b; !NILP (rest); rest = XCDR (XCDR (rest)))
{
Lisp_Object k = XCAR (rest);
Lisp_Object v = XCAR (XCDR (rest));
if (NILP (v)) continue;
for (i = 0; i < fill; i++)
{
if (EQ (k, keys [i]))
{
if ((eqp
? !EQ (v, vals [i])
: !internal_equal (v, vals [i], depth)))
/* a property in B has a different value than in A */
goto MISMATCH;
flags [i] = 1;
break;
}
}
if (i == fill)
/* there are some properties in B that are not in A */
goto MISMATCH;
}
/* Now check to see that all the properties in A were also in B */
for (i = 0; i < fill; i++)
if (flags [i] == 0)
goto MISMATCH;
/* Ok. */
return 0;
MISMATCH:
return 1;
}
DEFUN ("plists-eq", Fplists_eq, Splists_eq, 2, 2, 0,
"Return non-nil if property lists A and B are `eq'.\n\
A property list is an alternating list of keywords and values, where a nil\n\
value is equivalent to the property not existing. This function does\n\
order-insensitive comparisons of the property lists: For example, the\n\
property lists '(a 1 b 2 c nil) and '(b 2 a 1) are equal.\n\
Comparison between values is done using `eq'. See also `plists-equal'.")
(a, b)
Lisp_Object a, b;
{
check_plist_structure (a);
check_plist_structure (b);
return (plists_differ (a, b, -1) ? Qnil : Qt);
}
DEFUN ("plists-equal", Fplists_equal, Splists_equal, 2, 2, 0,
"Return non-nil if property lists A and B are `equal'.\n\
A property list is an alternating list of keywords and values, where a nil\n\
value is equivalent to the property not existing. This function does\n\
order-insensitive comparisons of the property lists: For example, the\n\
property lists '(a 1 b 2 c nil) and '(b 2 a 1) are equal.\n\
Comparison between values is done using `equal'. See also `plists-eq'.")
(a, b)
Lisp_Object a, b;
{
check_plist_structure (a);
check_plist_structure (b);
return (plists_differ (a, b, 1) ? Qnil : Qt);
}
/* Return the value associated with key PROPERTY in property list PLIST.
Return nil if key not found. This function is used for internal
property lists that cannot be directly manipulated by the user.
Perhaps we should merge this function with Fgetf ().
*/
int
internal_getf (Lisp_Object plist, Lisp_Object property,
Lisp_Object *value_out)
{
Lisp_Object tail = plist;
for (; !NILP (tail); tail = XCDR (XCDR (tail)))
{
struct Lisp_Cons *c = XCONS (tail);
if (EQ (c->car, property))
{
*value_out = XCAR (c->cdr);
return 1;
}
}
return 0;
}
/* Set PLIST's value for PROPERTY to VALUE. Analogous to internal_getf(). */
void
internal_putf (Lisp_Object *plist, Lisp_Object property, Lisp_Object value)
{
Lisp_Object tail = *plist;
for (; !NILP (tail); tail = XCDR (XCDR (tail)))
{
struct Lisp_Cons *c = XCONS (tail);
if (EQ (c->car, property))
{
XCAR (c->cdr) = value;
return;
}
}
*plist = Fcons (property, Fcons (value, *plist));
}
int
internal_remprop (Lisp_Object *plist, Lisp_Object property)
{
Lisp_Object tail = *plist;
if (NILP (tail))
return 0;
if (EQ (XCAR (tail), property))
{
*plist = XCDR (XCDR (tail));
return 1;
}
for (tail = XCDR (tail); !NILP (XCDR (tail));
tail = XCDR (XCDR (tail)))
{
struct Lisp_Cons *c = XCONS (tail);
if (EQ (XCAR (c->cdr), property))
{
c->cdr = XCDR (XCDR (c->cdr));
return 1;
}
}
return 0;
}
DEFUN ("getf", Fgetf, Sgetf, 2, 3, 0,
"Search PROPLIST for property PROPNAME; return its value or DEFAULT.\n\
PROPLIST is a list of the sort returned by `symbol-plist'.")
(plist, prop, defalt) /* Cant spel in C */
Lisp_Object plist, prop, defalt;
{
Lisp_Object tail;
for (tail = plist; !NILP (tail); tail = Fcdr (Fcdr (tail)))
{
if (EQ (prop, Fcar (tail)))
return Fcar (Fcdr (tail));
QUIT;
}
return defalt;
}
/* Symbol plists are directly accessible, so we need to protect against
invalid property list structure */
static Lisp_Object
symbol_getprop (Lisp_Object sym, Lisp_Object propname, Lisp_Object defalt)
{
return Fgetf (Fsymbol_plist (sym), propname, defalt);
}
static void
symbol_putprop (Lisp_Object sym, Lisp_Object propname, Lisp_Object value)
{
Lisp_Object tail;
Lisp_Object head = Fsymbol_plist (sym);
for (tail = head; !NILP (tail); tail = Fcdr (Fcdr (tail)))
if (EQ (propname, Fcar (tail)))
{
Fsetcar (Fcdr (tail), value);
return;
}
Fsetplist (sym, Fcons (propname, Fcons (value, head)));
}
static int
symbol_remprop (Lisp_Object symbol, Lisp_Object propname)
{
Lisp_Object tail;
Lisp_Object obj;
Lisp_Object prev;
unsigned char changed = 0;
tail = XSYMBOL (symbol)->plist;
obj = Fcar (tail);
while (!NILP (obj) && EQ (propname, obj))
{
changed = 1;
tail = Fcdr (Fcdr (tail));
obj = Fcar (tail);
}
XSYMBOL (symbol)->plist = tail;
prev = tail;
tail = Fcdr (Fcdr (tail));
while (!NILP (tail))
{
obj = Fcar (tail);
if (EQ (propname, obj))
{
changed = 1;
Fsetcdr (Fcdr (prev), (Fcdr (Fcdr (tail))));
}
prev = tail;
tail = Fcdr (Fcdr (tail));
}
return changed;
}
static Lisp_Object
symbol_props (Lisp_Object symbol)
{
return Fcopy_sequence (Fsymbol_plist (symbol));
}
/* We store the string's MODIFF as the first element of the string's
property list, but only if the string has been modified. This is ugly
but it reduces the memory allocated for the string in the vast
majority of cases, where the string is never modified. */
static Lisp_Object *
string_plist_ptr (struct Lisp_String *s)
{
return CONSP (s->plist) && INTP (XCAR (s->plist)) ?
&XCDR (s->plist) : &s->plist;
}
Lisp_Object
string_getprop (struct Lisp_String *s, Lisp_Object property,
Lisp_Object defalt)
{
Lisp_Object value;
if (internal_getf (*string_plist_ptr (s), property, &value))
return value;
return defalt;
}
void
string_putprop (struct Lisp_String *s, Lisp_Object property,
Lisp_Object value)
{
internal_putf (string_plist_ptr (s), property, value);
}
static int
string_remprop (struct Lisp_String *s, Lisp_Object property)
{
return internal_remprop (string_plist_ptr (s), property);
}
static Lisp_Object
string_props (struct Lisp_String *s)
{
return Fcopy_sequence (*string_plist_ptr (s));
}
DEFUN ("get", Fget, Sget, 2, 3, 0,
"Return the value of OBJECT's PROPNAME property.\n\
This is the last VALUE stored with `(put OBJECT PROPNAME VALUE)'.\n\
If there is no such property, return optional third arg DEFAULT\n\
(which defaults to `nil'). OBJECT can be a symbol, face, extent,\n\
or string. See also `put', `remprop', and `object-props'.")
(object, propname, defalt) /* Cant spel in C */
Lisp_Object object, propname, defalt;
{
Lisp_Object val;
/* Various places in emacs call Fget() and expect it not to quit, so if
the user puts a circular list in a symbol's plist, they get what they
deserve. */
Lisp_Object oiq = Vinhibit_quit;
Vinhibit_quit = Qt;
/* It's easiest to treat symbols specially because they may not
be an lrecord */
if (SYMBOLP (object))
val = symbol_getprop (object, propname, defalt);
else if (STRINGP (object))
val = string_getprop (XSTRING (object), propname, defalt);
else if (LRECORDP (object))
{
CONST struct lrecord_implementation
*imp = XRECORD_LHEADER (object)->implementation;
if (imp->getprop)
{
if (! (imp->getprop) (object, propname, &val))
val = defalt;
}
else
goto noprops;
}
else
{
noprops:
signal_simple_error ("Object type has no properties", object);
}
Vinhibit_quit = oiq;
return val;
}
DEFUN ("put", Fput, Sput, 3, 3, 0,
"Store OBJECT's PROPNAME property with value VALUE.\n\
It can be retrieved with `(get OBJECT PROPNAME)'. OBJECT can be a\n\
symbol, face, extent, or string.\n\
\n\
For a string, the following symbols have predefined meanings:\n\
\n\
dup-list List of string's extent replicas.\n\
\n\
For the predefined properties for extents, see `set-extent-property'.\n\
For the predefined properties for faces, see `set-face-property'.\n\
\n\
See also `get', `remprop', and `object-props'.")
(object, propname, value)
Lisp_Object object;
Lisp_Object propname;
Lisp_Object value;
{
CHECK_SYMBOL (propname, 1);
CHECK_IMPURE (object);
if (SYMBOLP (object))
symbol_putprop (object, propname, value);
else if (STRINGP (object))
string_putprop (XSTRING (object), propname, value);
else if (LRECORDP (object))
{
CONST struct lrecord_implementation
*imp = XRECORD_LHEADER (object)->implementation;
if (imp->putprop)
{
if (! (imp->putprop) (object, propname, value))
signal_simple_error ("Can't set property on object", propname);
}
else
goto noprops;
}
else
{
noprops:
signal_simple_error ("Object type has no settable properties", object);
}
return value;
}
void
pure_put (Lisp_Object sym, Lisp_Object prop, Lisp_Object val)
{
Fput (sym, prop, Fpurecopy (val));
}
DEFUN ("remprop", Fremprop, Sremprop, 2, 2, 0,
"Remove from OBJECT's property list the property PROPNAME and its\n\
value. OBJECT can be a symbol, face, extent, or string. Returns\n\
non-nil if the property list was actually changed (i.e. if PROPNAME\n\
was present in the property list). See also `get', `put', and\n\
`object-props'.")
(object, propname)
Lisp_Object object, propname;
{
int retval = 0;
CHECK_SYMBOL (propname, 1);
CHECK_IMPURE (object);
if (SYMBOLP (object))
retval = symbol_remprop (object, propname);
else if (STRINGP (object))
retval = string_remprop (XSTRING (object), propname);
else if (LRECORDP (object))
{
CONST struct lrecord_implementation
*imp = XRECORD_LHEADER (object)->implementation;
if (imp->remprop)
{
retval = (imp->remprop) (object, propname);
if (retval == -1)
signal_simple_error ("Can't remove property from object",
propname);
}
else
goto noprops;
}
else
{
noprops:
signal_simple_error ("Object type has no removable properties", object);
}
return retval ? Qt : Qnil;
}
DEFUN ("object-props", Fobject_props, Sobject_props, 1, 1, 0,
"Return a property list of OBJECT's props.\n\
This is a copy of OBJECT's property list, not the actual property list\n\
stored in the object; therefore, you cannot change a property on OBJECT\n\
by modifying this list. Use `put' for that.\n\
\n\
Note that for a symbol, this function is not the same as `symbol-plist';\n\
that function returns the actual property list, whereas `object-props'\n\
returns a copy of the property list.")
(object)
Lisp_Object object;
{
if (SYMBOLP (object))
return symbol_props (object);
else if (STRINGP (object))
return string_props (XSTRING (object));
else if (LRECORDP (object))
{
CONST struct lrecord_implementation
*imp = XRECORD_LHEADER (object)->implementation;
if (imp->props)
return (imp->props) (object);
else
signal_simple_error ("Object type has no properties", object);
}
return Qnil;
}
int
internal_equal (Lisp_Object o1, Lisp_Object o2, int depth)
{
if (depth > 200)
error ("Stack overflow in equal");
do_cdr:
QUIT;
if (EQ (o1, o2))
return (1);
/* Note that (equal 20 20.0) should be nil */
else if (XTYPE (o1) != XTYPE (o2))
return (0);
else if (CONSP (o1))
{
if (!internal_equal (Fcar (o1), Fcar (o2), depth + 1))
return (0);
o1 = Fcdr (o1);
o2 = Fcdr (o2);
goto do_cdr;
}
#ifndef LRECORD_VECTOR
else if (VECTORP (o1))
{
int index;
int len = vector_length (XVECTOR (o1));
if (len != vector_length (XVECTOR (o2)))
return (0);
for (index = 0; index < len; index++)
{
Lisp_Object v1, v2;
v1 = vector_data (XVECTOR (o1)) [index];
v2 = vector_data (XVECTOR (o2)) [index];
if (!internal_equal (v1, v2, depth + 1))
return (0);
}
return (1);
}
#endif /* !LRECORD_VECTOR */
else if (STRINGP (o1))
{
Bytecount len = string_length (XSTRING (o1));
if (len != string_length (XSTRING (o2)))
return (0);
if (memcmp (string_data (XSTRING (o1)), string_data (XSTRING (o2)), len))
return (0);
return (1);
}
else if (LRECORDP (o1))
{
CONST struct lrecord_implementation
*imp1 = XRECORD_LHEADER (o1)->implementation,
*imp2 = XRECORD_LHEADER (o2)->implementation;
if (imp1 != imp2)
return (0);
else if (imp1->equal == 0)
/* EQ-ness of the objects was noticed above */
return (0);
else
return ((imp1->equal) (o1, o2, depth));
}
return (0);
}
DEFUN ("equal", Fequal, Sequal, 2, 2, 0,
"T if two Lisp objects have similar structure and contents.\n\
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.")
(o1, o2)
Lisp_Object o1, o2;
{
return ((internal_equal (o1, o2, 0)) ? Qt : Qnil);
}
DEFUN ("fillarray", Ffillarray, Sfillarray, 2, 2, 0,
"Store each element of ARRAY with ITEM. ARRAY is a vector or string.")
(array, item)
Lisp_Object array, item;
{
retry:
if (VECTORP (array))
{
Lisp_Object *p;
int size;
int index;
CHECK_IMPURE (array);
size = vector_length (XVECTOR (array));
p = vector_data (XVECTOR (array));
for (index = 0; index < size; index++)
p[index] = item;
}
else if (STRINGP (array))
{
Charcount size;
Charcount index;
Emchar charval;
CHECK_COERCE_CHAR (item, 1);
CHECK_IMPURE (array);
charval = XINT (item);
size = string_char_length (XSTRING (array));
for (index = 0; index < size; index++)
set_string_char (XSTRING (array), index, charval);
bump_string_modiff (array);
}
else
{
array = wrong_type_argument (Qarrayp, array);
goto retry;
}
return array;
}
Lisp_Object
nconc2 (Lisp_Object s1, Lisp_Object s2)
{
Lisp_Object args[2];
args[0] = s1;
args[1] = s2;
return Fnconc (2, args);
}
DEFUN ("nconc", Fnconc, Snconc, 0, MANY, 0,
"Concatenate any number of lists by altering them.\n\
Only the last argument is not altered, and need not be a list.")
(nargs, args)
int nargs;
Lisp_Object *args;
{
int argnum;
Lisp_Object tail, tem, val;
struct gcpro gcpro1;
/* The modus operandi in Emacs is "caller gc-protects args".
However, nconc (particularly nconc2 ()) is called many times
in Emacs on freshly created stuff (e.g. you see the idiom
nconc2 (Fcopy_sequence (foo), bar) a lot). So we help those
callers out by protecting the args ourselves to save them
a lot of temporary-variable grief. */
GCPRO1 (args[0]);
gcpro1.nvars = nargs;
val = Qnil;
for (argnum = 0; argnum < nargs; argnum++)
{
tem = args[argnum];
if (NILP (tem)) continue;
if (NILP (val))
val = tem;
if (argnum + 1 == nargs) break;
if (!CONSP (tem))
tem = wrong_type_argument (Qlistp, tem);
while (CONSP (tem))
{
tail = tem;
tem = Fcdr (tail);
QUIT;
}
tem = args[argnum + 1];
Fsetcdr (tail, tem);
if (NILP (tem))
args[argnum + 1] = tail;
}
RETURN_UNGCPRO (val);
}
/* This is the guts of all mapping functions.
Apply fn to each element of seq, one by one,
storing the results into elements of vals, a C vector of Lisp_Objects.
leni is the length of vals, which should also be the length of seq. */
static void
mapcar1 (int leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq)
{
Lisp_Object tail;
Lisp_Object dummy;
int i;
struct gcpro gcpro1, gcpro2, gcpro3;
/* Don't let vals contain any garbage when GC happens. */
for (i = 0; i < leni; i++)
vals[i] = Qnil;
GCPRO3 (dummy, fn, seq);
gcpro1.var = vals;
gcpro1.nvars = leni;
/* 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 (VECTORP (seq))
{
for (i = 0; i < leni; i++)
{
dummy = vector_data (XVECTOR (seq))[i];
vals[i] = call1 (fn, dummy);
}
}
else if (STRINGP (seq))
{
for (i = 0; i < leni; i++)
{
vals[i] = call1 (fn, make_number (string_char (XSTRING (seq), i)));
}
}
else /* Must be a list, since Flength did not get an error */
{
tail = seq;
for (i = 0; i < leni; i++)
{
vals[i] = call1 (fn, Fcar (tail));
tail = Fcdr (tail);
}
}
UNGCPRO;
}
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 returned by FN.")
(fn, seq, sep)
Lisp_Object fn, seq, sep;
{
Lisp_Object len;
int leni;
int nargs;
Lisp_Object *args;
int i;
struct gcpro gcpro1;
len = Flength (seq);
leni = XINT (len);
nargs = leni + leni - 1;
if (nargs < 0) return build_string ("");
args = (Lisp_Object *) alloca (nargs * sizeof (Lisp_Object));
GCPRO1 (sep);
mapcar1 (leni, args, fn, seq);
UNGCPRO;
for (i = leni - 1; i >= 0; i--)
args[i + i] = args[i];
for (i = 1; i < nargs; i += 2)
args[i] = sep;
return Fconcat (nargs, args);
}
DEFUN ("mapcar", Fmapcar, Smapcar, 2, 2, 0,
"Apply FUNCTION to each element of SEQUENCE, and make a list of the results.\n\
The result is a list just as long as SEQUENCE.\n\
SEQUENCE may be a list, a vector or a string.")
(fn, seq)
Lisp_Object fn, seq;
{
Lisp_Object len;
int leni;
Lisp_Object *args;
len = Flength (seq);
leni = XINT (len);
args = (Lisp_Object *) alloca (leni * sizeof (Lisp_Object));
mapcar1 (leni, args, fn, seq);
return Flist (leni, args);
}
/* #### this function doesn't belong in this file! */
DEFUN ("load-average", Fload_average, Sload_average, 0, 0, 0,
"Return list of 1 minute, 5 minute and 15 minute load averages.\n\
Each of the three load averages is multiplied by 100,\n\
then converted to integer.\n\
\n\
If the 5-minute or 15-minute load averages are not available, return a\n\
shortened list, containing only those averages which are available.\n\
\n\
On most systems, this won't work unless the emacs executable is installed\n\
as setgid kmem (assuming that /dev/kmem is in the group kmem).")
()
{
double load_ave[10]; /* hey, just in case */
int loads = getloadavg (load_ave, 3);
Lisp_Object ret;
if (loads == -2)
error ("load-average not implemented for this operating system.");
else if (loads < 0)
error ("could not get load-average; check permissions.");
ret = Qnil;
while (loads > 0)
ret = Fcons (make_number ((int) (load_ave[--loads] * 100.0)), ret);
return ret;
}
Lisp_Object Vfeatures;
DEFUN ("featurep", Ffeaturep, Sfeaturep, 1, 1, 0,
"Return t if FEATURE is present in this Emacs.\n\
Use this to conditionalize execution of lisp code based on the presence or\n\
absence of emacs or environment extensions.\n\
Use `provide' to declare that a feature is available.\n\
This function looks at the value of the variable `features'.")
(feature)
Lisp_Object feature;
{
Lisp_Object tem;
CHECK_SYMBOL (feature, 0);
tem = Fmemq (feature, Vfeatures);
return (NILP (tem)) ? Qnil : Qt;
}
DEFUN ("provide", Fprovide, Sprovide, 1, 1, 0,
"Announce that FEATURE is a feature of the current Emacs.")
(feature)
Lisp_Object feature;
{
Lisp_Object tem;
CHECK_SYMBOL (feature, 0);
if (!NILP (Vautoload_queue))
Vautoload_queue = Fcons (Fcons (Vfeatures, Qnil), Vautoload_queue);
tem = Fmemq (feature, Vfeatures);
if (NILP (tem))
Vfeatures = Fcons (feature, Vfeatures);
LOADHIST_ATTACH (Fcons (Qprovide, feature));
return feature;
}
DEFUN ("require", Frequire, Srequire, 1, 2, 0,
"If feature FEATURE is not loaded, load it from FILENAME.\n\
If FEATURE is not a member of the list `features', then the feature\n\
is not loaded; so load the file FILENAME.\n\
If FILENAME is omitted, the printname of FEATURE is used as the file name.")
(feature, file_name)
Lisp_Object feature, file_name;
{
Lisp_Object tem;
CHECK_SYMBOL (feature, 0);
tem = Fmemq (feature, Vfeatures);
LOADHIST_ATTACH (Fcons (Qrequire, feature));
if (!NILP (tem))
return (feature);
else
{
int speccount = specpdl_depth ();
/* Value saved here is to be restored into Vautoload_queue */
record_unwind_protect (un_autoload, Vautoload_queue);
Vautoload_queue = Qt;
call4 (Qload, NILP (file_name) ? Fsymbol_name (feature) : file_name,
Qnil, Qt, Qnil);
tem = Fmemq (feature, Vfeatures);
if (NILP (tem))
error ("Required feature %s was not provided",
string_data (XSYMBOL (feature)->name));
/* Once loading finishes, don't undo it. */
Vautoload_queue = Qt;
return (unbind_to (speccount, feature));
}
}
Lisp_Object Qyes_or_no_p;
void
syms_of_fns (void)
{
defsymbol (&Qstring_lessp, "string-lessp");
defsymbol (&Qidentity, "identity");
defsymbol (&Qyes_or_no_p, "yes-or-no-p");
defsubr (&Sidentity);
defsubr (&Srandom);
defsubr (&Slength);
defsubr (&Sstring_equal);
defsubr (&Sstring_lessp);
defsubr (&Sstring_modified_tick);
defsubr (&Sappend);
defsubr (&Sconcat);
defsubr (&Svconcat);
defsubr (&Scopy_sequence);
defsubr (&Scopy_alist);
defsubr (&Scopy_tree);
defsubr (&Ssubstring);
defsubr (&Snthcdr);
defsubr (&Snth);
defsubr (&Selt);
defsubr (&Smember);
defsubr (&Smemq);
defsubr (&Sassoc);
defsubr (&Sassq);
defsubr (&Srassoc);
defsubr (&Srassq);
defsubr (&Sdelete);
defsubr (&Sdelq);
defsubr (&Sremassoc);
defsubr (&Sremassq);
defsubr (&Sremrassoc);
defsubr (&Sremrassq);
defsubr (&Snreverse);
defsubr (&Sreverse);
defsubr (&Ssort);
defsubr (&Splists_eq);
defsubr (&Splists_equal);
defsubr (&Sgetf);
defsubr (&Sget);
defsubr (&Sput);
defsubr (&Sremprop);
defsubr (&Sobject_props);
defsubr (&Sequal);
defsubr (&Sfillarray);
defsubr (&Snconc);
defsubr (&Smapcar);
defsubr (&Smapconcat);
defsubr (&Sload_average);
defsubr (&Sfeaturep);
defsubr (&Srequire);
defsubr (&Sprovide);
}
void
init_provide_once (void)
{
DEFVAR_LISP ("features", &Vfeatures,
"A list of symbols which are the features of the executing emacs.\n\
Used by `featurep' and `require', and altered by `provide'.");
Vfeatures = Qnil;
}
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.