xemacs-beta: src/data.c comparison

comparison src/data.c @ 0:376386a54a3c r19-14

Import from CVS: tag r19-14

author	cvs
date	Mon, 13 Aug 2007 08:45:50 +0200
parents
children	0293115a14e9

comparison

equal deleted inserted replaced

--1:000000000000
+:376386a54a3c
+/* Primitive operations on Lisp data types for XEmacs Lisp interpreter.
+Copyright (C) 1985, 1986, 1988, 1992, 1993, 1994, 1995
+Free Software Foundation, Inc.
+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, Inc., 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+/* Synched up with: Mule 2.0, FSF 19.30.  Some of FSF's data.c is in
+XEmacs' symbols.c. */
+/* This file has been Mule-ized. */
+#include <config.h>
+#include "lisp.h"
+#include "buffer.h"
+#include "bytecode.h"
+#include "syssignal.h"
+#ifdef LISP_FLOAT_TYPE
+/* Need to define a differentiating symbol -- see sysfloat.h */
+# define THIS_FILENAME data_c
+# include "sysfloat.h"
+#endif /* LISP_FLOAT_TYPE */
+Lisp_Object Qnil, Qt, Qquote, Qlambda, Qunbound;
+Lisp_Object Qerror_conditions, Qerror_message, Qtop_level;
+Lisp_Object Qsignal, Qerror, Qquit, Qwrong_type_argument, Qargs_out_of_range;
+Lisp_Object Qvoid_variable, Qcyclic_variable_indirection;
+Lisp_Object Qvoid_function, Qcyclic_function_indirection;
+Lisp_Object Qsetting_constant, Qinvalid_read_syntax;
+Lisp_Object Qmalformed_list, Qmalformed_property_list;
+Lisp_Object Qcircular_list, Qcircular_property_list;
+Lisp_Object Qinvalid_function, Qwrong_number_of_arguments, Qno_catch;
+Lisp_Object Qio_error, Qend_of_file;
+Lisp_Object Qarith_error, Qrange_error, Qdomain_error;
+Lisp_Object Qsingularity_error, Qoverflow_error, Qunderflow_error;
+Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only;
+Lisp_Object Qintegerp, Qnatnump, Qsymbolp, Qkeywordp, Qlistp, Qconsp, Qsubrp;
+Lisp_Object Qcharacterp, Qstringp, Qarrayp, Qsequencep, Qbufferp;
+Lisp_Object Qcompiled_functionp;
+Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qvectorp;
+Lisp_Object Qinteger_or_char_p, Qinteger_char_or_marker_p;
+Lisp_Object Qbit_vectorp, Qbitp;
+/* Qstring, Qinteger, Qsymbol, Qvector defined in general.c */
+Lisp_Object Qcons, Qkeyword;
+Lisp_Object Qcdr;
+Lisp_Object Qignore;
+#ifdef LISP_FLOAT_TYPE
+Lisp_Object Qfloatp;
+#endif
+Lisp_Object Qnumberp, Qnumber_or_marker_p, Qnumber_char_or_marker_p;
+Lisp_Object Qweak_listp;
+Lisp_Object
+wrong_type_argument (Lisp_Object predicate, Lisp_Object value)
+{
+/* This function can GC */
+REGISTER Lisp_Object tem;
+do
+{
+#ifdef MOCKLISP_SUPPORT
+if (!EQ (Vmocklisp_arguments, Qt))
+	{
+	 if (STRINGP (value) &&
+	     (EQ (predicate, Qintegerp) ||
+	      EQ (predicate, Qinteger_or_marker_p) ||
+	      EQ (predicate, Qinteger_char_or_marker_p)))
+	   return Fstring_to_number (value);
+	 if (INTP (value) && EQ (predicate, Qstringp))
+	   return Fnumber_to_string (value);
+	 if (CHARP (value) && EQ (predicate, Qstringp))
+	   return Fchar_to_string (value);
+	}
+#endif
+value = Fsignal (Qwrong_type_argument, list2 (predicate, value));
+tem = call1 (predicate, value);
+}
+while (NILP (tem));
+return value;
+}
+DOESNT_RETURN
+dead_wrong_type_argument (Lisp_Object predicate, Lisp_Object value)
+{
+signal_error (Qwrong_type_argument, list2 (predicate, value));
+}
+DEFUN ("wrong-type-argument", Fwrong_type_argument, Swrong_type_argument,
+2, 2, 0 /*
+Signal an error until the correct type value is given by the user.
+This function loops, signalling a continuable `wrong-type-argument' error
+with PREDICATE and VALUE as the data associated with the error and then
+calling PREDICATE on the returned value, until the value gotten satisfies
+PREDICATE.  At that point, the gotten value is returned.
+*/ )
+(predicate, value)
+Lisp_Object predicate, value;
+{
+return wrong_type_argument (predicate, value);
+}
+DOESNT_RETURN
+pure_write_error (void)
+{
+error ("Attempt to modify read-only object");
+}
+DOESNT_RETURN
+args_out_of_range (Lisp_Object a1, Lisp_Object a2)
+{
+signal_error (Qargs_out_of_range, list2 (a1, a2));
+}
+DOESNT_RETURN
+args_out_of_range_3 (Lisp_Object a1, Lisp_Object a2, Lisp_Object a3)
+{
+signal_error (Qargs_out_of_range, list3 (a1, a2, a3));
+}
+void
+check_int_range (int val, int min, int max)
+{
+if (val < min || val > max)
+args_out_of_range_3 (make_int (val), make_int (min),
+			 make_int (max));
+}
+#ifndef make_int
+Lisp_Object
+make_int (EMACS_INT num)
+{
+Lisp_Object val;
+/* Don't use XSETINT here -- it's defined in terms of make_int ().  */
+XSETOBJ (val, Lisp_Int, num);
+return val;
+}
+#endif /* ! defined (make_int) */
+/* On some machines, XINT needs a temporary location.
+Here it is, in case it is needed.  */
+EMACS_INT sign_extend_temp;
+/* On a few machines, XINT can only be done by calling this.  */
+/* XEmacs:  only used by m/convex.h */
+int sign_extend_lisp_int (EMACS_INT num);
+int
+sign_extend_lisp_int (EMACS_INT num)
+{
+if (num & (1L << (VALBITS - 1)))
+return num | ((-1L) << VALBITS);
+else
+return num & ((1L << VALBITS) - 1);
+}
+/* characters do not need to sign extend so there's no need for special
+futzing like with ints. */
+Lisp_Object
+make_char (Emchar num)
+{
+return make_int (num);
+}
+/* Data type predicates */
+DEFUN ("eq", Feq, Seq, 2, 2, 0 /*
+T if the two args are the same Lisp object.
+*/ )
+(obj1, obj2)
+Lisp_Object obj1, obj2;
+{
+if (EQ (obj1, obj2))
+return Qt;
+return Qnil;
+}
+DEFUN ("null", Fnull, Snull, 1, 1, 0 /*
+T if OBJECT is nil.
+*/ )
+(object)
+Lisp_Object object;
+{
+if (NILP (object))
+return Qt;
+return Qnil;
+}
+DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0 /*
+T if OBJECT is a cons cell.
+*/ )
+(object)
+Lisp_Object object;
+{
+if (CONSP (object))
+return Qt;
+return Qnil;
+}
+DEFUN ("atom", Fatom, Satom, 1, 1, 0 /*
+T if OBJECT is not a cons cell.  This includes nil.
+*/ )
+(object)
+Lisp_Object object;
+{
+if (CONSP (object))
+return Qnil;
+return Qt;
+}
+DEFUN ("listp", Flistp, Slistp, 1, 1, 0 /*
+T if OBJECT is a list.  This includes nil.
+*/ )
+(object)
+Lisp_Object object;
+{
+if (CONSP (object) || NILP (object))
+return Qt;
+return Qnil;
+}
+DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0 /*
+T if OBJECT is not a list.  Lists include nil.
+*/ )
+(object)
+Lisp_Object object;
+{
+if (CONSP (object) || NILP (object))
+return Qnil;
+return Qt;
+}
+DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0 /*
+T if OBJECT is a symbol.
+*/ )
+(object)
+Lisp_Object object;
+{
+if (SYMBOLP (object))
+return Qt;
+return Qnil;
+}
+DEFUN ("keywordp", Fkeywordp, Skeywordp, 1, 1, 0 /*
+T if OBJECT is a keyword.
+*/ )
+(object)
+Lisp_Object object;
+{
+if (KEYWORDP (object))
+return Qt;
+return Qnil;
+}
+DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0 /*
+T if OBJECT is a vector.
+*/ )
+(object)
+Lisp_Object object;
+{
+if (VECTORP (object))
+return Qt;
+return Qnil;
+}
+DEFUN ("bit-vector-p", Fbit_vector_p, Sbit_vector_p, 1, 1, 0 /*
+T if OBJECT is a bit vector.
+*/ )
+(object)
+Lisp_Object object;
+{
+if (BIT_VECTORP (object))
+return Qt;
+return Qnil;
+}
+DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0 /*
+T if OBJECT is a string.
+*/ )
+(object)
+Lisp_Object object;
+{
+if (STRINGP (object))
+return Qt;
+return Qnil;
+}
+DEFUN ("arrayp", Farrayp, Sarrayp, 1, 1, 0 /*
+T if OBJECT is an array (string, vector, or bit vector).
+*/ )
+(object)
+Lisp_Object object;
+{
+if (VECTORP (object) || STRINGP (object) || BIT_VECTORP (object))
+return Qt;
+return Qnil;
+}
+DEFUN ("sequencep", Fsequencep, Ssequencep, 1, 1, 0 /*
+T if OBJECT is a sequence (list or array).
+*/ )
+(object)
+Lisp_Object object;
+{
+if (CONSP (object) || NILP (object)
+|| VECTORP (object) || STRINGP (object) || BIT_VECTORP (object))
+return Qt;
+return Qnil;
+}
+DEFUN ("markerp", Fmarkerp, Smarkerp, 1, 1, 0 /*
+T if OBJECT is a marker (editor pointer).
+*/ )
+(object)
+Lisp_Object object;
+{
+if (MARKERP (object))
+return Qt;
+return Qnil;
+}
+DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0 /*
+T if OBJECT is a built-in function.
+*/ )
+(object)
+Lisp_Object object;
+{
+if (SUBRP (object))
+return Qt;
+return Qnil;
+}
+DEFUN ("subr-min-args", Fsubr_min_args, Ssubr_min_args, 1, 1, 0 /*
+Return minimum number of args built-in function SUBR may be called with.
+*/ )
+(subr)
+Lisp_Object subr;
+{
+CHECK_SUBR (subr);
+return make_int (XSUBR (subr)->min_args);
+}
+DEFUN ("subr-max-args", Fsubr_max_args, Ssubr_max_args, 1, 1, 0 /*
+Return maximum number of args built-in function SUBR may be called with,
+or nil if it takes an arbitrary number of arguments (or is a special form).
+*/ )
+(subr)
+Lisp_Object subr;
+{
+int nargs;
+CHECK_SUBR (subr);
+nargs = XSUBR (subr)->max_args;
+if (nargs == MANY || nargs == UNEVALLED)
+return Qnil;
+else
+return make_int (nargs);
+}
+DEFUN ("compiled-function-p", Fcompiled_function_p, Scompiled_function_p, 1, 1, 0 /*
+t if OBJECT is a byte-compiled function object.
+*/ )
+(object)
+Lisp_Object object;
+{
+if (COMPILED_FUNCTIONP (object))
+return Qt;
+return Qnil;
+}
+DEFUN ("characterp", Fcharacterp, Scharacterp, 1, 1, 0 /*
+t if OBJECT is a character.
+A character is an integer that can be inserted into a buffer with
+`insert-char'.  All integers are considered valid characters and are
+modded with 256 to get the actual character to use.
+*/ )
+(object)
+Lisp_Object object;
+{
+if (CHARP (object))
+return Qt;
+return Qnil;
+}
+DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0 /*
+t if OBJECT is a character or a string.
+*/ )
+(object)
+Lisp_Object object;
+{
+if (CHAR_OR_CHAR_INTP (object) || STRINGP (object))
+return Qt;
+return Qnil;
+}
+DEFUN ("integerp", Fintegerp, Sintegerp, 1, 1, 0 /*
+t if OBJECT is an integer.
+*/ )
+(object)
+Lisp_Object object;
+{
+if (INTP (object))
+return Qt;
+return Qnil;
+}
+DEFUN ("integer-or-marker-p", Finteger_or_marker_p, Sinteger_or_marker_p,
+1, 1, 0 /*
+t if OBJECT is an integer or a marker (editor pointer).
+*/ )
+(object)
+Lisp_Object object;
+{
+if (INTP (object) || MARKERP (object))
+return Qt;
+return Qnil;
+}
+DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0 /*
+t if OBJECT is a nonnegative integer.
+*/ )
+(object)
+Lisp_Object object;
+{
+if (NATNUMP (object))
+return Qt;
+return Qnil;
+}
+DEFUN ("bitp", Fbitp, Sbitp, 1, 1, 0 /*
+t if OBJECT is a bit (0 or 1).
+*/ )
+(object)
+Lisp_Object object;
+{
+if (BITP (object))
+return Qt;
+return Qnil;
+}
+DEFUN ("numberp", Fnumberp, Snumberp, 1, 1, 0 /*
+t if OBJECT is a number (floating point or integer).
+*/ )
+(object)
+Lisp_Object object;
+{
+if (INT_OR_FLOATP (object))
+return Qt;
+return Qnil;
+}
+DEFUN ("number-or-marker-p", Fnumber_or_marker_p, Snumber_or_marker_p, 1, 1, 0 /*
+t if OBJECT is a number or a marker.
+*/ )
+(object)
+Lisp_Object object;
+{
+if (INT_OR_FLOATP (object)
+|| MARKERP (object))
+return Qt;
+return Qnil;
+}
+#ifdef LISP_FLOAT_TYPE
+DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0 /*
+t if OBJECT is a floating point number.
+*/ )
+(object)
+Lisp_Object object;
+{
+if (FLOATP (object))
+return Qt;
+return Qnil;
+}
+#endif /* LISP_FLOAT_TYPE */
+DEFUN ("type-of", Ftype_of, Stype_of, 1, 1, 0 /*
+Return a symbol representing the type of OBJECT.
+*/ )
+(object)
+Lisp_Object object;
+{
+if (CONSP (object))
+return Qcons;
+if (SYMBOLP (object))
+return Qsymbol;
+if (KEYWORDP (object))
+return Qkeyword;
+if (INTP (object))
+return Qinteger;
+if (STRINGP (object))
+return Qstring;
+if (VECTORP (object))
+return Qvector;
+assert (LRECORDP (object));
+return intern (XRECORD_LHEADER (object)->implementation->name);
+}
+/* Extract and set components of lists */
+DEFUN ("car", Fcar, Scar, 1, 1, 0 /*
+Return the car of LIST.  If arg is nil, return nil.
+Error if arg is not nil and not a cons cell.  See also `car-safe'.
+*/ )
+(list)
+Lisp_Object list;
+{
+while (1)
+{
+if (CONSP (list))
+	return XCAR (list);
+else if (NILP (list))
+	return Qnil;
+else
+	list = wrong_type_argument (Qconsp, list);
+}
+}
+DEFUN ("car-safe", Fcar_safe, Scar_safe, 1, 1, 0 /*
+Return the car of OBJECT if it is a cons cell, or else nil.
+*/ )
+(object)
+Lisp_Object object;
+{
+if (CONSP (object))
+return XCAR (object);
+else
+return Qnil;
+}
+DEFUN ("cdr", Fcdr, Scdr, 1, 1, 0 /*
+Return the cdr of LIST.  If arg is nil, return nil.
+Error if arg is not nil and not a cons cell.  See also `cdr-safe'.
+*/ )
+(list)
+Lisp_Object list;
+{
+while (1)
+{
+if (CONSP (list))
+	return XCDR (list);
+else if (NILP (list))
+	return Qnil;
+else
+	list = wrong_type_argument (Qconsp, list);
+}
+}
+DEFUN ("cdr-safe", Fcdr_safe, Scdr_safe, 1, 1, 0 /*
+Return the cdr of OBJECT if it is a cons cell, or else  nil.
+*/ )
+(object)
+Lisp_Object object;
+{
+if (CONSP (object))
+return XCDR (object);
+else
+return Qnil;
+}
+DEFUN ("setcar", Fsetcar, Ssetcar, 2, 2, 0 /*
+Set the car of CONSCELL to be NEWCAR.  Returns NEWCAR.
+*/ )
+(conscell, newcar)
+Lisp_Object conscell, newcar;
+{
+if (!CONSP (conscell))
+conscell = wrong_type_argument (Qconsp, conscell);
+CHECK_IMPURE (conscell);
+XCAR (conscell) = newcar;
+return newcar;
+}
+DEFUN ("setcdr", Fsetcdr, Ssetcdr, 2, 2, 0 /*
+Set the cdr of CONSCELL to be NEWCDR.  Returns NEWCDR.
+*/ )
+(conscell, newcdr)
+Lisp_Object conscell, newcdr;
+{
+if (!CONSP (conscell))
+conscell = wrong_type_argument (Qconsp, conscell);
+CHECK_IMPURE (conscell);
+XCDR (conscell) = newcdr;
+return newcdr;
+}
+/* Find the function at the end of a chain of symbol function indirections.  */
+/* If OBJECT is a symbol, find the end of its function chain and
+return the value found there.  If OBJECT is not a symbol, just
+return it.  If there is a cycle in the function chain, signal a
+cyclic-function-indirection error.
+This is like Findirect_function, except that it doesn't signal an
+error if the chain ends up unbound.  */
+Lisp_Object
+indirect_function (Lisp_Object object, int errorp)
+{
+Lisp_Object tortoise = object;
+Lisp_Object hare = object;
+for (;;)
+{
+if (!SYMBOLP (hare) || UNBOUNDP (hare))
+	break;
+hare = XSYMBOL (hare)->function;
+if (!SYMBOLP (hare) || UNBOUNDP (hare))
+	break;
+hare = XSYMBOL (hare)->function;
+tortoise = XSYMBOL (tortoise)->function;
+if (EQ (hare, tortoise))
+	return (Fsignal (Qcyclic_function_indirection, list1 (object)));
+}
+if (UNBOUNDP (hare) && errorp)
+return Fsignal (Qvoid_function, list1 (object));
+return hare;
+}
+DEFUN ("indirect-function", Findirect_function, Sindirect_function, 1, 1, 0 /*
+Return the function at the end of OBJECT's function chain.
+If OBJECT is a symbol, follow all function indirections and return
+the final function binding.
+If OBJECT is not a symbol, just return it.
+Signal a void-function error if the final symbol is unbound.
+Signal a cyclic-function-indirection error if there is a loop in the
+function chain of symbols.
+*/ )
+(object)
+Lisp_Object object;
+{
+return indirect_function (object, 1);
+}
+/* Extract and set vector and string elements */
+DEFUN ("aref", Faref, Saref, 2, 2, 0 /*
+Return the element of ARRAY at index INDEX.
+ARRAY may be a vector, bit vector, string, or byte-code object.
+IDX starts at 0.
+*/ )
+(array, idx)
+Lisp_Object array;
+Lisp_Object idx;
+{
+int idxval;
+retry:
+CHECK_INT_COERCE_CHAR (idx); /* yuck! */
+idxval = XINT (idx);
+if (idxval < 0)
+{
+lose:
+args_out_of_range (array, idx);
+}
+if (VECTORP (array))
+{
+if (idxval >= vector_length (XVECTOR (array))) goto lose;
+return vector_data (XVECTOR (array))[idxval];
+}
+else if (BIT_VECTORP (array))
+{
+if (idxval >= bit_vector_length (XBIT_VECTOR (array))) goto lose;
+return make_int (bit_vector_bit (XBIT_VECTOR (array), idxval));
+}
+else if (STRINGP (array))
+{
+if (idxval >= string_char_length (XSTRING (array))) goto lose;
+return (make_char (string_char (XSTRING (array), idxval)));
+}
+#ifdef LOSING_BYTECODE
+else if (COMPILED_FUNCTIONP (array))
+{
+/* Weird, gross compatibility kludge */
+return (Felt (array, idx));
+}
+#endif
+else
+{
+check_losing_bytecode ("aref", array);
+array = wrong_type_argument (Qarrayp, array);
+goto retry;
+}
+}
+DEFUN ("aset", Faset, Saset, 3, 3, 0 /*
+Store into the element of ARRAY at index IDX the value NEWVAL.
+ARRAY may be a vector, bit vector, or string.  IDX starts at 0.
+*/ )
+(array, idx, newval)
+Lisp_Object array;
+Lisp_Object idx, newval;
+{
+int idxval;
+CHECK_INT_COERCE_CHAR (idx); /* yuck! */
+if (!VECTORP (array) && !BIT_VECTORP (array) && !STRINGP (array))
+array = wrong_type_argument (Qarrayp, array);
+idxval = XINT (idx);
+if (idxval < 0)
+{
+lose:
+args_out_of_range (array, idx);
+}
+CHECK_IMPURE (array);
+if (VECTORP (array))
+{
+if (idxval >= vector_length (XVECTOR (array))) goto lose;
+vector_data (XVECTOR (array))[idxval] = newval;
+}
+else if (BIT_VECTORP (array))
+{
+if (idxval >= bit_vector_length (XBIT_VECTOR (array))) goto lose;
+CHECK_BIT (newval);
+set_bit_vector_bit (XBIT_VECTOR (array), idxval, !ZEROP (newval));
+}
+else                          /* string */
+{
+CHECK_CHAR_COERCE_INT (newval);
+if (idxval >= string_char_length (XSTRING (array))) goto lose;
+set_string_char (XSTRING (array), idxval, XCHAR (newval));
+bump_string_modiff (array);
+}
+return newval;
+}
+/**********************************************************************/
+/*                      Compiled-function objects                     */
+/**********************************************************************/
+/* The compiled_function->doc_and_interactive slot uses the minimal
+number of conses, based on compiled_function->flags; it may take
+any of the following forms:
+	doc
+	interactive
+	domain
+	(doc . interactive)
+	(doc . domain)
+	(interactive . domain)
+	(doc . (interactive . domain))
+*/
+/* Caller must check flags.interactivep first */
+Lisp_Object
+compiled_function_interactive (struct Lisp_Compiled_Function *b)
+{
+assert (b->flags.interactivep);
+if (b->flags.documentationp && b->flags.domainp)
+return (XCAR (XCDR (b->doc_and_interactive)));
+else if (b->flags.documentationp)
+return (XCDR (b->doc_and_interactive));
+else if (b->flags.domainp)
+return (XCAR (b->doc_and_interactive));
+/* if all else fails... */
+return (b->doc_and_interactive);
+}
+/* Caller need not check flags.documentationp first */
+Lisp_Object
+compiled_function_documentation (struct Lisp_Compiled_Function *b)
+{
+if (! b->flags.documentationp)
+return Qnil;
+else if (b->flags.interactivep && b->flags.domainp)
+return (XCAR (b->doc_and_interactive));
+else if (b->flags.interactivep)
+return (XCAR (b->doc_and_interactive));
+else if (b->flags.domainp)
+return (XCAR (b->doc_and_interactive));
+else
+return (b->doc_and_interactive);
+}
+/* Caller need not check flags.domainp first */
+Lisp_Object
+compiled_function_domain (struct Lisp_Compiled_Function *b)
+{
+if (! b->flags.domainp)
+return Qnil;
+else if (b->flags.documentationp && b->flags.interactivep)
+return (XCDR (XCDR (b->doc_and_interactive)));
+else if (b->flags.documentationp)
+return (XCDR (b->doc_and_interactive));
+else if (b->flags.interactivep)
+return (XCDR (b->doc_and_interactive));
+else
+return (b->doc_and_interactive);
+}
+#ifdef COMPILED_FUNCTION_ANNOTATION_HACK
+Lisp_Object
+compiled_function_annotation (struct Lisp_Compiled_Function *b)
+{
+return b->annotated;
+}
+#endif
+/* used only by Snarf-documentation; there must be doc already. */
+void
+set_compiled_function_documentation (struct Lisp_Compiled_Function *b,
+				     Lisp_Object new)
+{
+assert (b->flags.documentationp);
+assert (INTP (new) || STRINGP (new));
+if (b->flags.interactivep && b->flags.domainp)
+XCAR (b->doc_and_interactive) = new;
+else if (b->flags.interactivep)
+XCAR (b->doc_and_interactive) = new;
+else if (b->flags.domainp)
+XCAR (b->doc_and_interactive) = new;
+else
+b->doc_and_interactive = new;
+}
+DEFUN ("compiled-function-instructions", Fcompiled_function_instructions,
+Scompiled_function_instructions, 1, 1, 0 /*
+Return the byte-opcode string of the compiled-function object.
+*/ )
+(function)
+Lisp_Object function;
+{
+CHECK_COMPILED_FUNCTION (function);
+return (XCOMPILED_FUNCTION (function)->bytecodes);
+}
+DEFUN ("compiled-function-constants", Fcompiled_function_constants,
+Scompiled_function_constants, 1, 1, 0 /*
+Return the constants vector of the compiled-function object.
+*/ )
+(function)
+Lisp_Object function;
+{
+CHECK_COMPILED_FUNCTION (function);
+return (XCOMPILED_FUNCTION (function)->constants);
+}
+DEFUN ("compiled-function-stack-depth", Fcompiled_function_stack_depth,
+Scompiled_function_stack_depth, 1, 1, 0 /*
+Return the max stack depth of the compiled-function object.
+*/ )
+(function)
+Lisp_Object function;
+{
+CHECK_COMPILED_FUNCTION (function);
+return (make_int (XCOMPILED_FUNCTION (function)->maxdepth));
+}
+DEFUN ("compiled-function-arglist", Fcompiled_function_arglist,
+Scompiled_function_arglist, 1, 1, 0 /*
+Return the argument list of the compiled-function object.
+*/ )
+(function)
+Lisp_Object function;
+{
+CHECK_COMPILED_FUNCTION (function);
+return (XCOMPILED_FUNCTION (function)->arglist);
+}
+DEFUN ("compiled-function-interactive", Fcompiled_function_interactive,
+Scompiled_function_interactive, 1, 1, 0 /*
+Return the interactive spec of the compiled-function object, or nil.
+If non-nil, the return value will be a list whose first element is
+`interactive' and whose second element is the interactive spec.
+*/ )
+(function)
+Lisp_Object function;
+{
+CHECK_COMPILED_FUNCTION (function);
+if (!XCOMPILED_FUNCTION (function)->flags.interactivep)
+return Qnil;
+return (list2 (Qinteractive,
+		 compiled_function_interactive
+		 (XCOMPILED_FUNCTION (function))));
+}
+DEFUN ("compiled-function-doc-string", Fcompiled_function_doc_string,
+Scompiled_function_doc_string, 1, 1, 0 /*
+Return the doc string of the compiled-function object, if available.
+*/ )
+(function)
+Lisp_Object function;
+{
+CHECK_COMPILED_FUNCTION (function);
+if (!XCOMPILED_FUNCTION (function)->flags.interactivep)
+return Qnil;
+return (list2 (Qinteractive,
+		 compiled_function_interactive
+		 (XCOMPILED_FUNCTION (function))));
+}
+#ifdef COMPILED_FUNCTION_ANNOTATION_HACK
+DEFUN ("compiled-function-annotation", Fcompiled_function_annotation,
+Scompiled_function_annotation, 1, 1, 0 /*
+Return the annotation of the compiled-function object, or nil.
+The annotation is a piece of information indicating where this
+compiled-function object came from.  Generally this will be
+a symbol naming a function; or a string naming a file, if the
+compiled-function object was not defined in a function; or nil,
+if the compiled-function object was not created as a result of
+a `load'.
+*/ )
+(function)
+Lisp_Object function;
+{
+CHECK_COMPILED_FUNCTION (function);
+return (compiled_function_annotation (XCOMPILED_FUNCTION (function)));
+}
+#endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
+DEFUN ("compiled-function-domain", Fcompiled_function_domain,
+Scompiled_function_domain, 1, 1, 0 /*
+Return the domain of the compiled-function object, or nil.
+This is only meaningful if I18N3 was enabled when emacs was compiled.
+*/ )
+(function)
+Lisp_Object function;
+{
+CHECK_COMPILED_FUNCTION (function);
+if (!XCOMPILED_FUNCTION (function)->flags.domainp)
+return Qnil;
+return (compiled_function_domain (XCOMPILED_FUNCTION (function)));
+}
+/**********************************************************************/
+/*                       Arithmetic functions                         */
+/**********************************************************************/
+enum comparison { equal, notequal, less, grtr, less_or_equal, grtr_or_equal };
+static Lisp_Object
+arithcompare (Lisp_Object num1, Lisp_Object num2,
+enum comparison comparison)
+{
+int floatp = 0;
+CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (num1);
+CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (num2);
+#ifdef LISP_FLOAT_TYPE
+if (FLOATP (num1) || FLOATP (num2))
+{
+double f1, f2;
+floatp = 1;
+f1 = (FLOATP (num1)) ? float_data (XFLOAT (num1)) : XINT (num1);
+f2 = (FLOATP (num2)) ? float_data (XFLOAT (num2)) : XINT (num2);
+switch (comparison)
+{
+case equal:
+if (f1 == f2)
+return Qt;
+return Qnil;
+case notequal:
+if (f1 != f2)
+return Qt;
+return Qnil;
+case less:
+if (f1 < f2)
+return Qt;
+return Qnil;
+case less_or_equal:
+if (f1 <= f2)
+return Qt;
+return Qnil;
+case grtr:
+if (f1 > f2)
+return Qt;
+return Qnil;
+case grtr_or_equal:
+if (f1 >= f2)
+return Qt;
+return Qnil;
+}
+}
+#endif /* LISP_FLOAT_TYPE */
+else
+{
+switch (comparison)
+{
+case equal:
+if (XINT (num1) == XINT (num2))
+return Qt;
+return Qnil;
+case notequal:
+if (XINT (num1) != XINT (num2))
+return Qt;
+return Qnil;
+case less:
+if (XINT (num1) < XINT (num2))
+return Qt;
+return Qnil;
+case less_or_equal:
+if (XINT (num1) <= XINT (num2))
+return Qt;
+return Qnil;
+case grtr:
+if (XINT (num1) > XINT (num2))
+return Qt;
+return Qnil;
+case grtr_or_equal:
+if (XINT (num1) >= XINT (num2))
+return Qt;
+return Qnil;
+}
+}
+abort ();
+return Qnil;	/* suppress compiler warning */
+}
+DEFUN ("=", Feqlsign, Seqlsign, 2, 2, 0 /*
+T if two args, both numbers or markers, are equal.
+*/ )
+(num1, num2)
+Lisp_Object num1, num2;
+{
+return arithcompare (num1, num2, equal);
+}
+DEFUN ("<", Flss, Slss, 2, 2, 0 /*
+T if first arg is less than second arg.  Both must be numbers or markers.
+*/ )
+(num1, num2)
+Lisp_Object num1, num2;
+{
+return arithcompare (num1, num2, less);
+}
+DEFUN (">", Fgtr, Sgtr, 2, 2, 0 /*
+T if first arg is greater than second arg.  Both must be numbers or markers.
+*/ )
+(num1, num2)
+Lisp_Object num1, num2;
+{
+return arithcompare (num1, num2, grtr);
+}
+DEFUN ("<=", Fleq, Sleq, 2, 2, 0 /*
+T if first arg is less than or equal to second arg.
+Both must be numbers or markers.
+*/ )
+(num1, num2)
+Lisp_Object num1, num2;
+{
+return arithcompare (num1, num2, less_or_equal);
+}
+DEFUN (">=", Fgeq, Sgeq, 2, 2, 0 /*
+T if first arg is greater than or equal to second arg.
+Both must be numbers or markers.
+*/ )
+(num1, num2)
+Lisp_Object num1, num2;
+{
+return arithcompare (num1, num2, grtr_or_equal);
+}
+DEFUN ("/=", Fneq, Sneq, 2, 2, 0 /*
+T if first arg is not equal to second arg.  Both must be numbers or markers.
+*/ )
+(num1, num2)
+Lisp_Object num1, num2;
+{
+return arithcompare (num1, num2, notequal);
+}
+DEFUN ("zerop", Fzerop, Szerop, 1, 1, 0 /*
+T if NUMBER is zero.
+*/ )
+(number)
+Lisp_Object number;
+{
+CHECK_INT_OR_FLOAT (number);
+#ifdef LISP_FLOAT_TYPE
+if (FLOATP (number))
+{
+if (float_data (XFLOAT (number)) == 0.0)
+	return Qt;
+return Qnil;
+}
+#endif /* LISP_FLOAT_TYPE */
+if (XINT (number) == 0)
+return Qt;
+return Qnil;
+}
+/* Convert between a 32-bit value and a cons of two 16-bit values.
+This is used to pass 32-bit integers to and from the user.
+Use time_to_lisp() and lisp_to_time() for time values.
+If you're thinking of using this to store a pointer into a Lisp Object
+for internal purposes (such as when calling record_unwind_protect()),
+try using make_opaque_ptr()/get_opaque_ptr() instead. */
+Lisp_Object
+word_to_lisp (unsigned int item)
+{
+return Fcons (make_int (item >> 16), make_int (item & 0xffff));
+}
+unsigned int
+lisp_to_word (Lisp_Object item)
+{
+if (INTP (item))
+return XINT (item);
+else
+{
+Lisp_Object top = Fcar (item);
+Lisp_Object bot = Fcdr (item);
+CHECK_INT (top);
+CHECK_INT (bot);
+return (XINT (top) << 16) | (XINT (bot) & 0xffff);
+}
+}
+DEFUN ("number-to-string", Fnumber_to_string, Snumber_to_string, 1, 1, 0 /*
+Convert NUM to a string by printing it in decimal.
+Uses a minus sign if negative.
+NUM may be an integer or a floating point number.
+*/ )
+(num)
+Lisp_Object num;
+{
+char buffer[VALBITS];
+CHECK_INT_OR_FLOAT (num);
+#ifdef LISP_FLOAT_TYPE
+if (FLOATP (num))
+{
+char pigbuf[350];	/* see comments in float_to_string */
+float_to_string (pigbuf, float_data (XFLOAT (num)));
+return build_string (pigbuf);
+}
+#endif /* LISP_FLOAT_TYPE */
+if (sizeof (int) == sizeof (EMACS_INT))
+sprintf (buffer, "%d", XINT (num));
+else if (sizeof (long) == sizeof (EMACS_INT))
+sprintf (buffer, "%ld", (long) XINT (num));
+else
+abort ();
+return build_string (buffer);
+}
+DEFUN ("string-to-number", Fstring_to_number, Sstring_to_number, 1, 1, 0 /*
+Convert STRING to a number by parsing it as a decimal number.
+This parses both integers and floating point numbers.
+It ignores leading spaces and tabs.
+*/ )
+(string)
+Lisp_Object string;
+{
+Lisp_Object value;
+char *p;
+CHECK_STRING (string);
+p = (char *) string_data (XSTRING (string));
+/* Skip any whitespace at the front of the number.  Some versions of
+atoi do this anyway, so we might as well make Emacs lisp consistent.  */
+while (*p == ' ' || *p == '\t')
+p++;
+#ifdef LISP_FLOAT_TYPE
+if (isfloat_string (p))
+return make_float (atof (p));
+#endif /* LISP_FLOAT_TYPE */
+if (sizeof (int) == sizeof (EMACS_INT))
+XSETINT (value, atoi (p));
+else if (sizeof (long) == sizeof (EMACS_INT))
+XSETINT (value, atol (p));
+else
+abort ();
+return value;
+}
+enum arithop
+{ Aadd, Asub, Amult, Adiv, Alogand, Alogior, Alogxor, Amax, Amin };
+#ifdef LISP_FLOAT_TYPE
+static Lisp_Object float_arith_driver (double accum, int argnum,
+enum arithop code,
+int nargs, Lisp_Object *args);
+#endif
+static Lisp_Object
+arith_driver (enum arithop code, int nargs, Lisp_Object *args)
+{
+Lisp_Object val;
+REGISTER int argnum;
+REGISTER EMACS_INT accum = 0;
+REGISTER EMACS_INT next;
+switch (code)
+{
+case Alogior:
+case Alogxor:
+case Aadd:
+case Asub:
+accum = 0; break;
+case Amult:
+accum = 1; break;
+case Alogand:
+accum = -1; break;
+case Adiv:
+case Amax:
+case Amin:
+accum = 0;
+break;
+default:
+abort ();
+}
+for (argnum = 0; argnum < nargs; argnum++)
+{
+val = args[argnum];    /* using args[argnum] as argument to CHECK_INT_OR_FLOAT_... */
+CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (val);
+#ifdef LISP_FLOAT_TYPE
+if (FLOATP (val)) /* time to do serious math */
+	return (float_arith_driver ((double) accum, argnum, code,
+				    nargs, args));
+#endif /* LISP_FLOAT_TYPE */
+args[argnum] = val;    /* runs into a compiler bug. */
+next = XINT (args[argnum]);
+switch (code)
+	{
+	case Aadd: accum += next; break;
+	case Asub:
+	  if (!argnum && nargs != 1)
+	    next = - next;
+	  accum -= next;
+	  break;
+	case Amult: accum *= next; break;
+	case Adiv:
+	  if (!argnum) accum = next;
+	  else
+	    {
+	      if (next == 0)
+		Fsignal (Qarith_error, Qnil);
+	      accum /= next;
+	    }
+	  break;
+	case Alogand: accum &= next; break;
+	case Alogior: accum |= next; break;
+	case Alogxor: accum ^= next; break;
+	case Amax: if (!argnum || next > accum) accum = next; break;
+	case Amin: if (!argnum || next < accum) accum = next; break;
+	}
+}
+XSETINT (val, accum);
+return val;
+}
+#ifdef LISP_FLOAT_TYPE
+static Lisp_Object
+float_arith_driver (double accum, int argnum, enum arithop code, int nargs,
+		    Lisp_Object *args)
+{
+REGISTER Lisp_Object val;
+double next;
+for (; argnum < nargs; argnum++)
+{
+val = args[argnum];    /* using args[argnum] as argument to CHECK_INT_OR_FLOAT_... */
+CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (val);
+if (FLOATP (val))
+	{
+	  next = float_data (XFLOAT (val));
+	}
+else
+	{
+	  args[argnum] = val;    /* runs into a compiler bug. */
+	  next = XINT (args[argnum]);
+	}
+switch (code)
+	{
+	case Aadd:
+	  accum += next;
+	  break;
+	case Asub:
+	  if (!argnum && nargs != 1)
+	    next = - next;
+	  accum -= next;
+	  break;
+	case Amult:
+	  accum *= next;
+	  break;
+	case Adiv:
+	  if (!argnum)
+	    accum = next;
+	  else
+	    {
+	      if (next == 0)
+		Fsignal (Qarith_error, Qnil);
+	      accum /= next;
+	    }
+	  break;
+	case Alogand:
+	case Alogior:
+	case Alogxor:
+	  return wrong_type_argument (Qinteger_or_marker_p, val);
+	case Amax:
+	  if (!argnum || isnan (next) || next > accum)
+	    accum = next;
+	  break;
+	case Amin:
+	  if (!argnum || isnan (next) || next < accum)
+	    accum = next;
+	  break;
+	}
+}
+return make_float (accum);
+}
+#endif /* LISP_FLOAT_TYPE */
+DEFUN ("+", Fplus, Splus, 0, MANY, 0 /*
+Return sum of any number of arguments, which are numbers or markers.
+*/ )
+(nargs, args)
+int nargs;
+Lisp_Object *args;
+{
+return arith_driver (Aadd, nargs, args);
+}
+DEFUN ("-", Fminus, Sminus, 0, MANY, 0 /*
+Negate number or subtract numbers or markers.
+With one arg, negates it.  With more than one arg,
+subtracts all but the first from the first.
+*/ )
+(nargs, args)
+int nargs;
+Lisp_Object *args;
+{
+return arith_driver (Asub, nargs, args);
+}
+DEFUN ("*", Ftimes, Stimes, 0, MANY, 0 /*
+Return product of any number of arguments, which are numbers or markers.
+*/ )
+(nargs, args)
+int nargs;
+Lisp_Object *args;
+{
+return arith_driver (Amult, nargs, args);
+}
+DEFUN ("/", Fquo, Squo, 2, MANY, 0 /*
+Return first argument divided by all the remaining arguments.
+The arguments must be numbers or markers.
+*/ )
+(nargs, args)
+int nargs;
+Lisp_Object *args;
+{
+return arith_driver (Adiv, nargs, args);
+}
+DEFUN ("%", Frem, Srem, 2, 2, 0 /*
+Return remainder of first arg divided by second.
+Both must be integers or markers.
+*/ )
+(num1, num2)
+Lisp_Object num1, num2;
+{
+CHECK_INT_COERCE_CHAR_OR_MARKER (num1);
+CHECK_INT_COERCE_CHAR_OR_MARKER (num2);
+if (ZEROP (num2))
+Fsignal (Qarith_error, Qnil);
+return (make_int (XINT (num1) % XINT (num2)));
+}
+/* Note, ANSI *requires* the presence of the fmod() library routine.
+If your system doesn't have it, complain to your vendor, because
+that is a bug. */
+#ifndef HAVE_FMOD
+double
+fmod (double f1, double f2)
+{
+if (f2 < 0.0)
+f2 = -f2;
+return (f1 - f2 * floor (f1/f2));
+}
+#endif /* ! HAVE_FMOD */
+DEFUN ("mod", Fmod, Smod, 2, 2, 0 /*
+Return X modulo Y.
+The result falls between zero (inclusive) and Y (exclusive).
+Both X and Y must be numbers or markers.
+If either argument is a float, a float will be returned.
+*/ )
+(x, y)
+Lisp_Object x, y;
+{
+EMACS_INT i1, i2;
+#ifdef LISP_FLOAT_TYPE
+CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (x);
+CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (y);
+if (FLOATP (x) || FLOATP (y))
+{
+double f1, f2;
+f1 = ((FLOATP (x)) ? float_data (XFLOAT (x)) : XINT (x));
+f2 = ((FLOATP (y)) ? float_data (XFLOAT (y)) : XINT (y));
+if (f2 == 0)
+	Fsignal (Qarith_error, Qnil);
+f1 = fmod (f1, f2);
+/* If the "remainder" comes out with the wrong sign, fix it.  */
+if (f2 < 0 ? f1 > 0 : f1 < 0)
+	f1 += f2;
+return (make_float (f1));
+}
+#else /* not LISP_FLOAT_TYPE */
+CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (x);
+CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (y);
+#endif /* not LISP_FLOAT_TYPE */
+i1 = XINT (x);
+i2 = XINT (y);
+if (i2 == 0)
+Fsignal (Qarith_error, Qnil);
+i1 %= i2;
+/* If the "remainder" comes out with the wrong sign, fix it.  */
+if (i2 < 0 ? i1 > 0 : i1 < 0)
+i1 += i2;
+return (make_int (i1));
+}
+DEFUN ("max", Fmax, Smax, 1, MANY, 0 /*
+Return largest of all the arguments (which must be numbers or markers).
+The value is always a number; markers are converted to numbers.
+*/ )
+(nargs, args)
+int nargs;
+Lisp_Object *args;
+{
+return arith_driver (Amax, nargs, args);
+}
+DEFUN ("min", Fmin, Smin, 1, MANY, 0 /*
+Return smallest of all the arguments (which must be numbers or markers).
+The value is always a number; markers are converted to numbers.
+*/ )
+(nargs, args)
+int nargs;
+Lisp_Object *args;
+{
+return arith_driver (Amin, nargs, args);
+}
+DEFUN ("logand", Flogand, Slogand, 0, MANY, 0 /*
+Return bitwise-and of all the arguments.
+Arguments may be integers, or markers converted to integers.
+*/ )
+(nargs, args)
+int nargs;
+Lisp_Object *args;
+{
+return arith_driver (Alogand, nargs, args);
+}
+DEFUN ("logior", Flogior, Slogior, 0, MANY, 0 /*
+Return bitwise-or of all the arguments.
+Arguments may be integers, or markers converted to integers.
+*/ )
+(nargs, args)
+int nargs;
+Lisp_Object *args;
+{
+return arith_driver (Alogior, nargs, args);
+}
+DEFUN ("logxor", Flogxor, Slogxor, 0, MANY, 0 /*
+Return bitwise-exclusive-or of all the arguments.
+Arguments may be integers, or markers converted to integers.
+*/ )
+(nargs, args)
+int nargs;
+Lisp_Object *args;
+{
+return arith_driver (Alogxor, nargs, args);
+}
+DEFUN ("ash", Fash, Sash, 2, 2, 0 /*
+Return VALUE with its bits shifted left by COUNT.
+If COUNT is negative, shifting is actually to the right.
+In this case, the sign bit is duplicated.
+*/ )
+(value, count)
+Lisp_Object value, count;
+{
+CHECK_INT_COERCE_CHAR (value);
+CHECK_INT (count);
+if (XINT (count) > 0)
+return (make_int (XINT (value) << XINT (count)));
+else
+return (make_int (XINT (value) >> -XINT (count)));
+}
+DEFUN ("lsh", Flsh, Slsh, 2, 2, 0 /*
+Return VALUE with its bits shifted left by COUNT.
+If COUNT is negative, shifting is actually to the right.
+In this case,  zeros are shifted in on the left.
+*/ )
+(value, count)
+Lisp_Object value, count;
+{
+Lisp_Object val;
+CHECK_INT_COERCE_CHAR (value);
+CHECK_INT (count);
+if (XINT (count) > 0)
+XSETINT (val, (EMACS_UINT) XUINT (value) << XINT (count));
+else
+XSETINT (val, (EMACS_UINT) XUINT (value) >> -XINT (count));
+return val;
+}
+DEFUN ("1+", Fadd1, Sadd1, 1, 1, 0 /*
+Return NUMBER plus one.  NUMBER may be a number or a marker.
+Markers are converted to integers.
+*/ )
+(number)
+Lisp_Object number;
+{
+CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (number);
+#ifdef LISP_FLOAT_TYPE
+if (FLOATP (number))
+return (make_float (1.0 + float_data (XFLOAT (number))));
+#endif /* LISP_FLOAT_TYPE */
+return (make_int (XINT (number) + 1));
+}
+DEFUN ("1-", Fsub1, Ssub1, 1, 1, 0 /*
+Return NUMBER minus one.  NUMBER may be a number or a marker.
+Markers are converted to integers.
+*/ )
+(number)
+Lisp_Object number;
+{
+CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (number);
+#ifdef LISP_FLOAT_TYPE
+if (FLOATP (number))
+return (make_float (-1.0 + (float_data (XFLOAT (number)))));
+#endif /* LISP_FLOAT_TYPE */
+return (make_int (XINT (number) - 1));
+}
+DEFUN ("lognot", Flognot, Slognot, 1, 1, 0 /*
+Return the bitwise complement of NUMBER.  NUMBER must be an integer.
+*/ )
+(number)
+Lisp_Object number;
+{
+CHECK_INT (number);
+return (make_int (~XINT (number)));
+}
+/************************************************************************/
+/*                              weak lists                              */
+/************************************************************************/
+/* A weak list is like a normal list except that elements automatically
+disappear when no longer in use, i.e. when no longer GC-protected.
+The basic idea is that we don't mark the elements during GC, but
+wait for them to be marked elsewhere.  If they're not marked, we
+remove them.  This is analogous to weak hashtables; see the explanation
+there for more info. */
+static Lisp_Object mark_weak_list (Lisp_Object, void (*) (Lisp_Object));
+static void print_weak_list (Lisp_Object, Lisp_Object, int);
+static int weak_list_equal (Lisp_Object, Lisp_Object, int depth);
+static unsigned long weak_list_hash (Lisp_Object obj, int depth);
+DEFINE_LRECORD_IMPLEMENTATION ("weak-list", weak_list,
+mark_weak_list, print_weak_list,
+			       0, weak_list_equal, weak_list_hash,
+			       struct weak_list);
+static Lisp_Object Vall_weak_lists; /* Gemarke es nicht!!! */
+static Lisp_Object encode_weak_list_type (enum weak_list_type type);
+static Lisp_Object
+mark_weak_list (Lisp_Object obj, void (*markobj) (Lisp_Object))
+{
+return Qnil; /* nichts ist gemarkt */
+}
+static void
+print_weak_list (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
+{
+if (print_readably)
+error ("printing unreadable object #<weak-list>");
+write_c_string ("#<weak-list ", printcharfun);
+print_internal (encode_weak_list_type (XWEAK_LIST (obj)->type),
+		  printcharfun, 0);
+write_c_string (" ", printcharfun);
+print_internal (XWEAK_LIST (obj)->list, printcharfun, escapeflag);
+write_c_string (">", printcharfun);
+}
+static int
+weak_list_equal (Lisp_Object o1, Lisp_Object o2, int depth)
+{
+struct weak_list *w1 = XWEAK_LIST (o1);
+struct weak_list *w2 = XWEAK_LIST (o2);
+if (w1->type != w2->type ||
+!internal_equal (w1->list, w2->list, depth + 1))
+return 0;
+else
+return 1;
+}
+static unsigned long
+weak_list_hash (Lisp_Object obj, int depth)
+{
+struct weak_list *w = XWEAK_LIST (obj);
+return HASH2 ((unsigned long) w->type,
+		internal_hash (w->list, depth + 1));
+}
+Lisp_Object
+make_weak_list (enum weak_list_type type)
+{
+Lisp_Object result = Qnil;
+struct weak_list *wl =
+alloc_lcrecord (sizeof (struct weak_list), lrecord_weak_list);
+wl->list = Qnil;
+wl->type = type;
+XSETWEAK_LIST (result, wl);
+wl->next_weak = Vall_weak_lists;
+Vall_weak_lists = result;
+return result;
+}
+/*
+-- we do not mark the list elements (either the elements themselves
+or the cons cells that hold them) in the normal marking phase.
+-- at the end of marking, we go through all weak lists that are
+marked, and mark the cons cells that hold all marked
+objects, and possibly parts of the objects themselves.
+(See alloc.c, "after-mark".)
+-- after that, we prune away all the cons cells that are not marked.
+WARNING WARNING WARNING WARNING WARNING:
+The code in the following two functions is *unbelievably* tricky.
+Don't mess with it.  You'll be sorry.
+Linked lists just majorly suck, d'ya know?
+*/
+int
+finish_marking_weak_lists (int (*obj_marked_p) (Lisp_Object),
+			   void (*markobj) (Lisp_Object))
+{
+Lisp_Object rest;
+int did_mark = 0;
+for (rest = Vall_weak_lists;
+!GC_NILP (rest);
+rest = XWEAK_LIST (rest)->next_weak)
+{
+Lisp_Object rest2;
+enum weak_list_type type = XWEAK_LIST (rest)->type;
+if (! ((*obj_marked_p) (rest)))
+	/* The weak list is probably garbage.  Ignore it. */
+	continue;
+for (rest2 = XWEAK_LIST (rest)->list;
+	   /* We need to be trickier since we're inside of GC;
+	      use CONSP instead of !NILP in case of user-visible
+	      imperfect lists */
+	   GC_CONSP (rest2);
+	   rest2 = XCDR (rest2))
+	{
+	  Lisp_Object elem;
+	  /* If the element is "marked" (meaning depends on the type
+	     of weak list), we need to mark the cons containing the
+	     element, and maybe the element itself (if only some part
+	     was already marked). */
+	  int need_to_mark_cons = 0;
+	  int need_to_mark_elem = 0;
+	  /* If a cons is already marked, then its car is already marked
+	     (either because of an external pointer or because of
+	     a previous call to this function), and likewise for all
+	     the rest of the elements in the list, so we can stop now. */
+	  if ((*obj_marked_p) (rest2))
+	    break;
+	  elem = XCAR (rest2);
+	  switch (type)
+	    {
+	    case WEAK_LIST_SIMPLE:
+	      if ((*obj_marked_p) (elem))
+		need_to_mark_cons = 1;
+	      break;
+	    case WEAK_LIST_ASSOC:
+	      if (!GC_CONSP (elem))
+		{
+		  /* just leave bogus elements there */
+		  need_to_mark_cons = 1;
+		  need_to_mark_elem = 1;
+		}
+	      else if ((*obj_marked_p) (XCAR (elem)) &&
+		  (*obj_marked_p) (XCDR (elem)))
+		{
+		  need_to_mark_cons = 1;
+		  /* We still need to mark elem, because it's
+		     probably not marked. */
+		  need_to_mark_elem = 1;
+		}
+	      break;
+	    case WEAK_LIST_KEY_ASSOC:
+	      if (!GC_CONSP (elem))
+		{
+		  /* just leave bogus elements there */
+		  need_to_mark_cons = 1;
+		  need_to_mark_elem = 1;
+		}
+	      else if ((*obj_marked_p) (XCAR (elem)))
+		{
+		  need_to_mark_cons = 1;
+		  /* We still need to mark elem and XCDR (elem);
+		     marking elem does both */
+		  need_to_mark_elem = 1;
+		}
+	      break;
+	    case WEAK_LIST_VALUE_ASSOC:
+	      if (!GC_CONSP (elem))
+		{
+		  /* just leave bogus elements there */
+		  need_to_mark_cons = 1;
+		  need_to_mark_elem = 1;
+		}
+	      else if ((*obj_marked_p) (XCDR (elem)))
+		{
+		  need_to_mark_cons = 1;
+		  /* We still need to mark elem and XCAR (elem);
+		     marking elem does both */
+		  need_to_mark_elem = 1;
+		}
+	      break;
+	    default:
+	      abort ();
+	    }
+	  if (need_to_mark_elem && ! (*obj_marked_p) (elem))
+	    {
+	      (*markobj) (elem);
+	      did_mark = 1;
+	    }
+	  /* We also need to mark the cons that holds the elem or
+	     assoc-pair.  We do *not* want to call (markobj) here
+	     because that will mark the entire list; we just want to
+	     mark the cons itself.
+	     */
+	  if (need_to_mark_cons)
+	    {
+	      struct Lisp_Cons *ptr = XCONS (rest2);
+	      if (!CONS_MARKED_P (ptr))
+		{
+		  MARK_CONS (ptr);
+		  did_mark = 1;
+		}
+	    }
+	}
+/* In case of imperfect list, need to mark the final cons
+because we're not removing it */
+if (!GC_NILP (rest2) && ! (obj_marked_p) (rest2))
+	{
+	  (markobj) (rest2);
+	  did_mark = 1;
+	}
+}
+return did_mark;
+}
+void
+prune_weak_lists (int (*obj_marked_p) (Lisp_Object))
+{
+Lisp_Object rest, prev = Qnil;
+for (rest = Vall_weak_lists;
+!GC_NILP (rest);
+rest = XWEAK_LIST (rest)->next_weak)
+{
+if (! ((*obj_marked_p) (rest)))
+	{
+	  /* This weak list itself is garbage.  Remove it from the list. */
+	  if (GC_NILP (prev))
+	    Vall_weak_lists = XWEAK_LIST (rest)->next_weak;
+	  else
+	    XWEAK_LIST (prev)->next_weak =
+	      XWEAK_LIST (rest)->next_weak;
+	}
+else
+	{
+	  Lisp_Object rest2, prev2 = Qnil;
+	  Lisp_Object tortoise;
+	  int go_tortoise = 0;
+for (rest2 = XWEAK_LIST (rest)->list, tortoise = rest2;
+	       /* We need to be trickier since we're inside of GC;
+		  use CONSP instead of !NILP in case of user-visible
+		  imperfect lists */
+	       GC_CONSP (rest2);)
+	    {
+	      /* It suffices to check the cons for marking,
+		 regardless of the type of weak list:
+		 -- if the cons is pointed to somewhere else,
+		    then it should stay around and will be marked.
+		 -- otherwise, if it should stay around, it will
+		    have been marked in finish_marking_weak_lists().
+		 -- otherwise, it's not marked and should disappear.
+		 */
+	      if (!(*obj_marked_p) (rest2))
+		{
+		  /* bye bye :-( */
+		  if (GC_NILP (prev2))
+		    XWEAK_LIST (rest)->list = XCDR (rest2);
+		  else
+		    XCDR (prev2) = XCDR (rest2);
+		  rest2 = XCDR (rest2);
+		  /* Ouch.  Circularity checking is even trickier
+		     than I thought.  When we cut out a link
+		     like this, we can't advance the turtle or
+		     it'll catch up to us.  Imagine that we're
+		     standing on floor tiles and moving forward --
+		     what we just did here is as if the floor
+		     tile under us just disappeared and all the
+		     ones ahead of us slid one tile towards us.
+		     In other words, we didn't move at all;
+		     if the tortoise was one step behind us
+		     previously, it still is, and therefore
+		     it must not move. */
+		}
+	      else
+		{
+		  prev2 = rest2;
+		  /* Implementing circularity checking is trickier here
+		     than in other places because we have to guarantee
+		     that we've processed all elements before exiting
+		     due to a circularity. (In most places, an error
+		     is issued upon encountering a circularity, so it
+		     doesn't really matter if all elements are processed.)
+		     The idea is that we process along with the hare
+		     rather than the tortoise.  If at any point in
+		     our forward process we encounter the tortoise,
+		     we must have already visited the spot, so we exit.
+		     (If we process with the tortoise, we can fail to
+		     process cases where a cons points to itself, or
+		     where cons A points to cons B, which points to
+		     cons A.) */
+		  rest2 = XCDR (rest2);
+		  if (go_tortoise)
+		    tortoise = XCDR (tortoise);
+		  go_tortoise = !go_tortoise;
+		  if (GC_EQ (rest2, tortoise))
+		    break;
+		}
+	    }
+	  prev = rest;
+	}
+}
+}
+static enum weak_list_type
+decode_weak_list_type (Lisp_Object symbol)
+{
+CHECK_SYMBOL (symbol);
+if (EQ (symbol, Qsimple))
+return WEAK_LIST_SIMPLE;
+if (EQ (symbol, Qassoc))
+return WEAK_LIST_ASSOC;
+if (EQ (symbol, Qkey_assoc))
+return WEAK_LIST_KEY_ASSOC;
+if (EQ (symbol, Qvalue_assoc))
+return WEAK_LIST_VALUE_ASSOC;
+signal_simple_error ("Invalid weak list type", symbol);
+return WEAK_LIST_SIMPLE; /* not reached */
+}
+static Lisp_Object
+encode_weak_list_type (enum weak_list_type type)
+{
+switch (type)
+{
+case WEAK_LIST_SIMPLE:
+return Qsimple;
+case WEAK_LIST_ASSOC:
+return Qassoc;
+case WEAK_LIST_KEY_ASSOC:
+return Qkey_assoc;
+case WEAK_LIST_VALUE_ASSOC:
+return Qvalue_assoc;
+default:
+abort ();
+}
+return Qnil;
+}
+DEFUN ("weak-list-p", Fweak_list_p, Sweak_list_p, 1, 1, 0 /*
+Return non-nil if OBJECT is a weak list.
+*/ )
+(object)
+Lisp_Object object;
+{
+return WEAK_LISTP (object) ? Qt : Qnil;
+}
+DEFUN ("make-weak-list", Fmake_weak_list, Smake_weak_list, 0, 1, 0 /*
+Create a new weak list.
+A weak list object is an object that contains a list.  This list behaves
+like any other list except that its elements do not count towards
+garbage collection -- if the only pointer to an object in inside a weak
+list (other than pointers in similar objects such as weak hash tables),
+the object is garbage collected and automatically removed from the list.
+This is used internally, for example, to manage the list holding the
+children of an extent -- an extent that is unused but has a parent will
+still be reclaimed, and will automatically be removed from its parent's
+list of children.
+Optional argument TYPE specifies the type of the weak list, and defaults
+to `simple'.  Recognized types are
+`simple'	Objects in the list disappear if not pointed to.
+`assoc'		Objects in the list disappear if they are conses
+		and either the car or the cdr of the cons is not
+		pointed to.
+`key-assoc'	Objects in the list disappear if they are conses
+		and the car is not pointed to.
+`value-assoc'	Objects in the list disappear if they are conses
+		and the cdr is not pointed to.
+*/ )
+(type)
+Lisp_Object type;
+{
+if (NILP (type))
+type = Qsimple;
+return make_weak_list (decode_weak_list_type (type));
+}
+DEFUN ("weak-list-type", Fweak_list_type, Sweak_list_type, 1, 1, 0 /*
+Return the type of the given weak-list object.
+*/ )
+(weak)
+Lisp_Object weak;
+{
+CHECK_WEAK_LIST (weak);
+return encode_weak_list_type (XWEAK_LIST (weak)->type);
+}
+DEFUN ("weak-list-list", Fweak_list_list, Sweak_list_list, 1, 1, 0 /*
+Return the list contained in a weak-list object.
+*/ )
+(weak)
+Lisp_Object weak;
+{
+CHECK_WEAK_LIST (weak);
+return XWEAK_LIST_LIST (weak);
+}
+DEFUN ("set-weak-list-list", Fset_weak_list_list, Sset_weak_list_list,
+2, 2, 0 /*
+Change the list contained in a weak-list object.
+*/ )
+(weak, new_list)
+Lisp_Object weak, new_list;
+{
+CHECK_WEAK_LIST (weak);
+XWEAK_LIST_LIST (weak) = new_list;
+return new_list;
+}
+/************************************************************************/
+/*                            initialization                            */
+/************************************************************************/
+static SIGTYPE
+arith_error (int signo)
+{
+EMACS_REESTABLISH_SIGNAL (signo, arith_error);
+EMACS_UNBLOCK_SIGNAL (signo);
+signal_error (Qarith_error, Qnil);
+}
+void
+init_data_very_early (void)
+{
+/* Don't do this if just dumping out.
+We don't want to call `signal' in this case
+so that we don't have trouble with dumping
+signal-delivering routines in an inconsistent state.  */
+#ifndef CANNOT_DUMP
+if (!initialized)
+return;
+#endif /* CANNOT_DUMP */
+signal (SIGFPE, arith_error);
+#ifdef uts
+signal (SIGEMT, arith_error);
+#endif /* uts */
+}
+void
+init_errors_once_early (void)
+{
+defsymbol (&Qerror_conditions, "error-conditions");
+defsymbol (&Qerror_message, "error-message");
+/* We declare the errors here because some other deferrors depend
+on some of the errors below. */
+/* ERROR is used as a signaler for random errors for which nothing
+else is right */
+deferror (&Qerror, "error", "error", Qnil);
+deferror (&Qquit, "quit", "Quit", Qnil);
+deferror (&Qwrong_type_argument, "wrong-type-argument",
+	    "Wrong type argument", Qerror);
+deferror (&Qargs_out_of_range, "args-out-of-range", "Args out of range",
+	    Qerror);
+deferror (&Qvoid_function, "void-function",
+	    "Symbol's function definition is void", Qerror);
+deferror (&Qcyclic_function_indirection, "cyclic-function-indirection",
+	    "Symbol's chain of function indirections contains a loop", Qerror);
+deferror (&Qvoid_variable, "void-variable",
+	    "Symbol's value as variable is void", Qerror);
+deferror (&Qcyclic_variable_indirection, "cyclic-variable-indirection",
+	    "Symbol's chain of variable indirections contains a loop", Qerror);
+deferror (&Qsetting_constant, "setting-constant",
+	    "Attempt to set a constant symbol", Qerror);
+deferror (&Qinvalid_read_syntax, "invalid-read-syntax",
+	    "Invalid read syntax", Qerror);
+deferror (&Qmalformed_list, "malformed-list",
+	    "Malformed list", Qerror);
+deferror (&Qmalformed_property_list, "malformed-property-list",
+	    "Malformed property list", Qerror);
+deferror (&Qcircular_list, "circular-list",
+	    "Circular list", Qerror);
+deferror (&Qcircular_property_list, "circular-property-list",
+	    "Circular property list", Qerror);
+deferror (&Qinvalid_function, "invalid-function", "Invalid function",
+	    Qerror);
+deferror (&Qwrong_number_of_arguments, "wrong-number-of-arguments",
+	    "Wrong number of arguments", Qerror);
+deferror (&Qno_catch, "no-catch", "No catch for tag",
+	    Qerror);
+deferror (&Qbeginning_of_buffer, "beginning-of-buffer",
+	    "Beginning of buffer", Qerror);
+deferror (&Qend_of_buffer, "end-of-buffer", "End of buffer", Qerror);
+deferror (&Qbuffer_read_only, "buffer-read-only", "Buffer is read-only",
+	    Qerror);
+deferror (&Qio_error, "io-error", "IO Error", Qerror);
+deferror (&Qend_of_file, "end-of-file", "End of stream", Qio_error);
+deferror (&Qarith_error, "arith-error", "Arithmetic error", Qerror);
+deferror (&Qrange_error, "range-error", "Arithmetic range error",
+	    Qarith_error);
+deferror (&Qdomain_error, "domain-error", "Arithmetic domain error",
+	    Qarith_error);
+deferror (&Qsingularity_error, "singularity-error",
+	    "Arithmetic singularity error", Qdomain_error);
+deferror (&Qoverflow_error, "overflow-error",
+	    "Arithmetic overflow error", Qdomain_error);
+deferror (&Qunderflow_error, "underflow-error",
+	    "Arithmetic underflow error", Qdomain_error);
+}
+void
+syms_of_data (void)
+{
+defsymbol (&Qcons, "cons");
+defsymbol (&Qkeyword, "keyword");
+/* Qstring, Qinteger, Qsymbol, Qvector defined in general.c */
+defsymbol (&Qquote, "quote");
+defsymbol (&Qlambda, "lambda");
+defsymbol (&Qsignal, "signal");
+defsymbol (&Qtop_level, "top-level");
+defsymbol (&Qignore, "ignore");
+defsymbol (&Qlistp, "listp");
+defsymbol (&Qconsp, "consp");
+defsymbol (&Qsubrp, "subrp");
+defsymbol (&Qsymbolp, "symbolp");
+defsymbol (&Qkeywordp, "keywordp");
+defsymbol (&Qintegerp, "integerp");
+defsymbol (&Qcharacterp, "characterp");
+defsymbol (&Qnatnump, "natnump");
+defsymbol (&Qstringp, "stringp");
+defsymbol (&Qarrayp, "arrayp");
+defsymbol (&Qsequencep, "sequencep");
+defsymbol (&Qbufferp, "bufferp");
+defsymbol (&Qbitp, "bitp");
+defsymbol (&Qbit_vectorp, "bit-vector-p");
+defsymbol (&Qvectorp, "vectorp");
+defsymbol (&Qcompiled_functionp, "compiled-function-p");
+defsymbol (&Qchar_or_string_p, "char-or-string-p");
+defsymbol (&Qmarkerp, "markerp");
+defsymbol (&Qinteger_or_marker_p, "integer-or-marker-p");
+/* HACK for 19.x only. */
+defsymbol (&Qinteger_char_or_marker_p, "integer-or-marker-p");
+#ifdef LISP_FLOAT_TYPE
+defsymbol (&Qfloatp, "floatp");
+#endif /* LISP_FLOAT_TYPE */
+defsymbol (&Qnumberp, "numberp");
+defsymbol (&Qnumber_or_marker_p, "number-or-marker-p");
+/* HACK for 19.x only. */
+defsymbol (&Qnumber_char_or_marker_p, "number-or-marker-p");
+defsymbol (&Qcdr, "cdr");
+defsymbol (&Qweak_listp, "weak-list-p");
+defsubr (&Swrong_type_argument);
+defsubr (&Seq);
+defsubr (&Snull);
+defsubr (&Slistp);
+defsubr (&Snlistp);
+defsubr (&Sconsp);
+defsubr (&Satom);
+defsubr (&Schar_or_string_p);
+defsubr (&Scharacterp);
+defsubr (&Sintegerp);
+defsubr (&Sinteger_or_marker_p);
+defsubr (&Snumberp);
+defsubr (&Snumber_or_marker_p);
+#ifdef LISP_FLOAT_TYPE
+defsubr (&Sfloatp);
+#endif /* LISP_FLOAT_TYPE */
+defsubr (&Snatnump);
+defsubr (&Ssymbolp);
+defsubr (&Skeywordp);
+defsubr (&Sstringp);
+defsubr (&Svectorp);
+defsubr (&Sbitp);
+defsubr (&Sbit_vector_p);
+defsubr (&Sarrayp);
+defsubr (&Ssequencep);
+defsubr (&Smarkerp);
+defsubr (&Ssubrp);
+defsubr (&Ssubr_min_args);
+defsubr (&Ssubr_max_args);
+defsubr (&Scompiled_function_p);
+defsubr (&Stype_of);
+defsubr (&Scar);
+defsubr (&Scdr);
+defsubr (&Scar_safe);
+defsubr (&Scdr_safe);
+defsubr (&Ssetcar);
+defsubr (&Ssetcdr);
+defsubr (&Sindirect_function);
+defsubr (&Saref);
+defsubr (&Saset);
+defsubr (&Scompiled_function_instructions);
+defsubr (&Scompiled_function_constants);
+defsubr (&Scompiled_function_stack_depth);
+defsubr (&Scompiled_function_arglist);
+defsubr (&Scompiled_function_interactive);
+defsubr (&Scompiled_function_doc_string);
+defsubr (&Scompiled_function_domain);
+#ifdef COMPILED_FUNCTION_ANNOTATION_HACK
+defsubr (&Scompiled_function_annotation);
+#endif
+defsubr (&Snumber_to_string);
+defsubr (&Sstring_to_number);
+defsubr (&Seqlsign);
+defsubr (&Slss);
+defsubr (&Sgtr);
+defsubr (&Sleq);
+defsubr (&Sgeq);
+defsubr (&Sneq);
+defsubr (&Szerop);
+defsubr (&Splus);
+defsubr (&Sminus);
+defsubr (&Stimes);
+defsubr (&Squo);
+defsubr (&Srem);
+defsubr (&Smod);
+defsubr (&Smax);
+defsubr (&Smin);
+defsubr (&Slogand);
+defsubr (&Slogior);
+defsubr (&Slogxor);
+defsubr (&Slsh);
+defsubr (&Sash);
+defsubr (&Sadd1);
+defsubr (&Ssub1);
+defsubr (&Slognot);
+defsubr (&Sweak_list_p);
+defsubr (&Smake_weak_list);
+defsubr (&Sweak_list_type);
+defsubr (&Sweak_list_list);
+defsubr (&Sset_weak_list_list);
+}
+void
+vars_of_data (void)
+{
+/* This must not be staticpro'd */
+Vall_weak_lists = Qnil;
+}

Mercurial > hg > xemacs-beta

comparison src/data.c @ 0:376386a54a3c r19-14