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;
+Lisp_Object Qintegerp, Qnatnump, Qsymbolp, Qkeywordp;
Lisp_Object Qlistp, Qtrue_list_p, Qweak_listp;
-Lisp_Object Qconsp, Qsubrp;
+Lisp_Object Qconsp, Qsubrp, Qcompiled_functionp;
Lisp_Object Qcharacterp, Qstringp, Qarrayp, Qsequencep, Qvectorp;
Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qbufferp;
Lisp_Object Qinteger_or_char_p, Qinteger_char_or_marker_p;
-Lisp_Object Qnumberp, Qnumber_char_or_marker_p;
-Lisp_Object Qbit_vectorp, Qbitp, Qcdr;
+Lisp_Object Qnumberp, Qnumber_or_marker_p, Qnumber_char_or_marker_p;
+Lisp_Object Qbit_vectorp, Qbitp, Qcons, Qkeyword, Qcdr, Qignore;
+#ifdef LISP_FLOAT_TYPE
Lisp_Object Qfloatp;
+#endif
#ifdef DEBUG_XEMACS
int debug_ebola_backtrace_length;
+#if 0
+/*#ifndef LRECORD_SYMBOL*/
+#include "backtrace.h"
+#endif
+
int
eq_with_ebola_notice (Lisp_Object obj1, Lisp_Object obj2)
{
- if (debug_issue_ebola_notices
- && ((CHARP (obj1) && INTP (obj2)) || (CHARP (obj2) && INTP (obj1))))
+ if (((CHARP (obj1) && INTP (obj2)) || (CHARP (obj2) && INTP (obj1)))
+ && (debug_issue_ebola_notices >= 2
+ || XCHAR_OR_INT (obj1) == XCHAR_OR_INT (obj2)))
{
- /* #### It would be really nice if this were a proper warning
- instead of brain-dead print ro Qexternal_debugging_output. */
- write_c_string ("Comparison between integer and character is constant nil (",
- Qexternal_debugging_output);
+ stderr_out("Comparison between integer and character is constant nil (");
Fprinc (obj1, Qexternal_debugging_output);
- write_c_string (" and ", Qexternal_debugging_output);
+ stderr_out (" and ");
Fprinc (obj2, Qexternal_debugging_output);
- write_c_string (")\n", Qexternal_debugging_output);
+ stderr_out (")\n");
debug_short_backtrace (debug_ebola_backtrace_length);
}
return EQ (obj1, obj2);
}
DOESNT_RETURN
-c_write_error (Lisp_Object obj)
-{
- signal_simple_error ("Attempt to modify read-only object (c)", obj);
-}
-
-DOESNT_RETURN
-lisp_write_error (Lisp_Object obj)
+pure_write_error (Lisp_Object obj)
{
- signal_simple_error ("Attempt to modify read-only object (lisp)", obj);
+ signal_simple_error ("Attempt to modify read-only object", obj);
}
DOESNT_RETURN
}
void
-check_int_range (EMACS_INT val, EMACS_INT min, EMACS_INT max)
+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));
/* On a few machines, XINT can only be done by calling this. */
/* XEmacs: only used by m/convex.h */
-EMACS_INT sign_extend_lisp_int (EMACS_INT num);
-EMACS_INT
+int sign_extend_lisp_int (EMACS_INT num);
+int
sign_extend_lisp_int (EMACS_INT num)
{
if (num & (1L << (VALBITS - 1)))
}
DEFUN ("consp", Fconsp, 1, 1, 0, /*
-Return t if OBJECT is a cons cell. `nil' is not a cons cell.
+Return t if OBJECT is a cons cell.
*/
(object))
{
}
DEFUN ("atom", Fatom, 1, 1, 0, /*
-Return t if OBJECT is not a cons cell. `nil' is not a cons cell.
+Return t if OBJECT is not a cons cell. Atoms include nil.
*/
(object))
{
}
DEFUN ("listp", Flistp, 1, 1, 0, /*
-Return t if OBJECT is a list. `nil' is a list.
+Return t if OBJECT is a list. Lists includes nil.
*/
(object))
{
}
DEFUN ("nlistp", Fnlistp, 1, 1, 0, /*
-Return t if OBJECT is not a list. `nil' is a list.
+Return t if OBJECT is not a list. Lists include nil.
*/
(object))
{
}
DEFUN ("vectorp", Fvectorp, 1, 1, 0, /*
-Return t if OBJECT is a vector.
+REturn t if OBJECT is a vector.
*/
(object))
{
*/
(object))
{
- return (LISTP (object) ||
+ return (CONSP (object) ||
+ NILP (object) ||
VECTORP (object) ||
STRINGP (object) ||
BIT_VECTORP (object))
return prompt ? list2 (Qinteractive, build_string (prompt)) : Qnil;
}
+DEFUN ("compiled-function-p", Fcompiled_function_p, 1, 1, 0, /*
+Return t if OBJECT is a byte-compiled function object.
+*/
+ (object))
+{
+ return COMPILED_FUNCTIONP (object) ? Qt : Qnil;
+}
+
\f
DEFUN ("characterp", Fcharacterp, 1, 1, 0, /*
Return t if OBJECT is a character.
*/
(object))
{
- switch (XTYPE (object))
- {
- case Lisp_Type_Record:
- return intern (XRECORD_LHEADER_IMPLEMENTATION (object)->name);
+ if (CONSP (object)) return Qcons;
+ if (SYMBOLP (object)) return Qsymbol;
+ if (KEYWORDP (object)) return Qkeyword;
+ if (INTP (object)) return Qinteger;
+ if (CHARP (object)) return Qcharacter;
+ if (STRINGP (object)) return Qstring;
+ if (VECTORP (object)) return Qvector;
- case Lisp_Type_Char: return Qcharacter;
-
- default: return Qinteger;
- }
+ assert (LRECORDP (object));
+ return intern (XRECORD_LHEADER_IMPLEMENTATION (object)->name);
}
\f
if (!CONSP (conscell))
conscell = wrong_type_argument (Qconsp, conscell);
+ CHECK_IMPURE (conscell);
XCAR (conscell) = newcar;
return newcar;
}
if (!CONSP (conscell))
conscell = wrong_type_argument (Qconsp, conscell);
+ CHECK_IMPURE (conscell);
XCDR (conscell) = newcdr;
return newcdr;
}
\f
-/* Find the function at the end of a chain of symbol function indirections.
+/* 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
+/* 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.
Lisp_Object
indirect_function (Lisp_Object object, int errorp)
{
-#define FUNCTION_INDIRECTION_SUSPICION_LENGTH 16
- Lisp_Object tortoise, hare;
- int count;
+ Lisp_Object tortoise = object;
+ Lisp_Object hare = object;
- for (hare = tortoise = object, count = 0;
- SYMBOLP (hare);
- hare = XSYMBOL (hare)->function, count++)
+ for (;;)
{
- if (count < FUNCTION_INDIRECTION_SUSPICION_LENGTH) continue;
+ 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 (count & 1)
- tortoise = XSYMBOL (tortoise)->function;
if (EQ (hare, tortoise))
return Fsignal (Qcyclic_function_indirection, list1 (object));
}
- if (errorp && UNBOUNDP (hare))
- return signal_void_function_error (object);
-
+ if (UNBOUNDP (hare) && errorp)
+ return Fsignal (Qvoid_function, list1 (object));
return hare;
}
DEFUN ("aref", Faref, 2, 2, 0, /*
Return the element of ARRAY at index INDEX.
-ARRAY may be a vector, bit vector, or string. INDEX starts at 0.
+ARRAY may be a vector, bit vector, string, or byte-code object.
+IDX starts at 0.
*/
- (array, index_))
+ (array, idx))
{
- EMACS_INT idx;
+ int idxval;
retry:
-
- if (INTP (index_)) idx = XINT (index_);
- else if (CHARP (index_)) idx = XCHAR (index_); /* yuck! */
- else
+ CHECK_INT_COERCE_CHAR (idx); /* yuck! */
+ idxval = XINT (idx);
+ if (idxval < 0)
{
- index_ = wrong_type_argument (Qinteger_or_char_p, index_);
- goto retry;
+ lose:
+ args_out_of_range (array, idx);
}
-
- if (idx < 0) goto range_error;
-
if (VECTORP (array))
{
- if (idx >= XVECTOR_LENGTH (array)) goto range_error;
- return XVECTOR_DATA (array)[idx];
+ if (idxval >= XVECTOR_LENGTH (array)) goto lose;
+ return XVECTOR_DATA (array)[idxval];
}
else if (BIT_VECTORP (array))
{
- if (idx >= bit_vector_length (XBIT_VECTOR (array))) goto range_error;
- return make_int (bit_vector_bit (XBIT_VECTOR (array), idx));
+ 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 (idx >= XSTRING_CHAR_LENGTH (array)) goto range_error;
- return make_char (string_char (XSTRING (array), idx));
+ if (idxval >= XSTRING_CHAR_LENGTH (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, index_);
+ return Felt (array, idx);
}
#endif
else
array = wrong_type_argument (Qarrayp, array);
goto retry;
}
-
- range_error:
- args_out_of_range (array, index_);
- return Qnil; /* not reached */
}
DEFUN ("aset", Faset, 3, 3, 0, /*
-Store into the element of ARRAY at index INDEX the value NEWVAL.
-ARRAY may be a vector, bit vector, or string. INDEX starts at 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, index_, newval))
+ (array, idx, newval))
{
- EMACS_INT idx;
+ int idxval;
- retry:
+ CHECK_INT_COERCE_CHAR (idx); /* yuck! */
+ if (!VECTORP (array) && !BIT_VECTORP (array) && !STRINGP (array))
+ array = wrong_type_argument (Qarrayp, array);
- if (INTP (index_)) idx = XINT (index_);
- else if (CHARP (index_)) idx = XCHAR (index_); /* yuck! */
- else
+ idxval = XINT (idx);
+ if (idxval < 0)
{
- index_ = wrong_type_argument (Qinteger_or_char_p, index_);
- goto retry;
+ lose:
+ args_out_of_range (array, idx);
}
-
- if (idx < 0) goto range_error;
+ CHECK_IMPURE (array);
if (VECTORP (array))
{
- if (idx >= XVECTOR_LENGTH (array)) goto range_error;
- XVECTOR_DATA (array)[idx] = newval;
+ if (idxval >= XVECTOR_LENGTH (array)) goto lose;
+ XVECTOR_DATA (array)[idxval] = newval;
}
else if (BIT_VECTORP (array))
{
- if (idx >= bit_vector_length (XBIT_VECTOR (array))) goto range_error;
+ if (idxval >= bit_vector_length (XBIT_VECTOR (array))) goto lose;
CHECK_BIT (newval);
- set_bit_vector_bit (XBIT_VECTOR (array), idx, !ZEROP (newval));
+ set_bit_vector_bit (XBIT_VECTOR (array), idxval, !ZEROP (newval));
}
- else if (STRINGP (array))
+ else /* string */
{
CHECK_CHAR_COERCE_INT (newval);
- if (idx >= XSTRING_CHAR_LENGTH (array)) goto range_error;
- set_string_char (XSTRING (array), idx, XCHAR (newval));
+ if (idxval >= XSTRING_CHAR_LENGTH (array)) goto lose;
+ set_string_char (XSTRING (array), idxval, XCHAR (newval));
bump_string_modiff (array);
}
- else
- {
- array = wrong_type_argument (Qarrayp, array);
- goto retry;
- }
return newval;
-
- range_error:
- args_out_of_range (array, index_);
- return Qnil; /* not reached */
}
\f
/**********************************************************************/
-/* Arithmetic functions */
+/* Compiled-function objects */
/**********************************************************************/
-typedef struct
+
+/* 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)
{
- int int_p;
- union
- {
- EMACS_INT ival;
- double dval;
- } c;
-} int_or_double;
+ 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);
-static void
-number_char_or_marker_to_int_or_double (Lisp_Object obj, int_or_double *p)
+ /* 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)
{
- retry:
- p->int_p = 1;
- if (INTP (obj)) p->c.ival = XINT (obj);
- else if (CHARP (obj)) p->c.ival = XCHAR (obj);
- else if (MARKERP (obj)) p->c.ival = marker_position (obj);
-#ifdef LISP_FLOAT_TYPE
- else if (FLOATP (obj)) p->c.dval = XFLOAT_DATA (obj), p->int_p = 0;
-#endif
+ 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
- {
- obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
- goto retry;
- }
+ return b->doc_and_interactive;
}
-static double
-number_char_or_marker_to_double (Lisp_Object obj)
+/* Caller need not check flags.domainp first */
+Lisp_Object
+compiled_function_domain (struct Lisp_Compiled_Function *b)
{
- retry:
- if (INTP (obj)) return (double) XINT (obj);
- else if (CHARP (obj)) return (double) XCHAR (obj);
- else if (MARKERP (obj)) return (double) marker_position (obj);
-#ifdef LISP_FLOAT_TYPE
- else if (FLOATP (obj)) return XFLOAT_DATA (obj);
-#endif
+ 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
- {
- obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
- goto retry;
- }
+ return b->doc_and_interactive;
}
-static EMACS_INT
-integer_char_or_marker_to_int (Lisp_Object obj)
+#ifdef COMPILED_FUNCTION_ANNOTATION_HACK
+
+Lisp_Object
+compiled_function_annotation (struct Lisp_Compiled_Function *b)
{
- retry:
- if (INTP (obj)) return XINT (obj);
- else if (CHARP (obj)) return XCHAR (obj);
- else if (MARKERP (obj)) return marker_position (obj);
+ 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, 1, 1, 0, /*
+Return the byte-opcode string of the compiled-function object.
+*/
+ (function))
+{
+ CHECK_COMPILED_FUNCTION (function);
+ return XCOMPILED_FUNCTION (function)->bytecodes;
+}
+
+DEFUN ("compiled-function-constants", Fcompiled_function_constants, 1, 1, 0, /*
+Return the constants vector of the compiled-function object.
+*/
+ (function))
+{
+ CHECK_COMPILED_FUNCTION (function);
+ return XCOMPILED_FUNCTION (function)->constants;
+}
+
+DEFUN ("compiled-function-stack-depth", Fcompiled_function_stack_depth, 1, 1, 0, /*
+Return the max stack depth of the compiled-function object.
+*/
+ (function))
+{
+ CHECK_COMPILED_FUNCTION (function);
+ return make_int (XCOMPILED_FUNCTION (function)->maxdepth);
+}
+
+DEFUN ("compiled-function-arglist", Fcompiled_function_arglist, 1, 1, 0, /*
+Return the argument list of the compiled-function object.
+*/
+ (function))
+{
+ CHECK_COMPILED_FUNCTION (function);
+ return XCOMPILED_FUNCTION (function)->arglist;
+}
+
+DEFUN ("compiled-function-interactive", Fcompiled_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))
+{
+ CHECK_COMPILED_FUNCTION (function);
+ return XCOMPILED_FUNCTION (function)->flags.interactivep
+ ? list2 (Qinteractive,
+ compiled_function_interactive (XCOMPILED_FUNCTION (function)))
+ : Qnil;
+}
+
+DEFUN ("compiled-function-doc-string", Fcompiled_function_doc_string, 1, 1, 0, /*
+Return the doc string of the compiled-function object, if available.
+Functions that had their doc strings snarfed into the DOC file will have
+an integer returned instead of a string.
+*/
+ (function))
+{
+ CHECK_COMPILED_FUNCTION (function);
+ return compiled_function_documentation (XCOMPILED_FUNCTION (function));
+}
+
+#ifdef COMPILED_FUNCTION_ANNOTATION_HACK
+
+/* Remove the `xx' if you wish to restore this feature */
+xxDEFUN ("compiled-function-annotation", Fcompiled_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))
+{
+ CHECK_COMPILED_FUNCTION (function);
+ return compiled_function_annotation (XCOMPILED_FUNCTION (function));
+}
+
+#endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
+
+DEFUN ("compiled-function-domain", Fcompiled_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))
+{
+ CHECK_COMPILED_FUNCTION (function);
+ return XCOMPILED_FUNCTION (function)->flags.domainp
+ ? compiled_function_domain (XCOMPILED_FUNCTION (function))
+ : Qnil;
+}
+
+\f
+/**********************************************************************/
+/* Arithmetic functions */
+/**********************************************************************/
+
+Lisp_Object
+arithcompare (Lisp_Object num1, Lisp_Object num2,
+ enum arith_comparison comparison)
+{
+ 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))
{
- obj = wrong_type_argument (Qinteger_char_or_marker_p, obj);
- goto retry;
+ double f1 = FLOATP (num1) ? float_data (XFLOAT (num1)) : XINT (num1);
+ double f2 = FLOATP (num2) ? float_data (XFLOAT (num2)) : XINT (num2);
+
+ switch (comparison)
+ {
+ case arith_equal: return f1 == f2 ? Qt : Qnil;
+ case arith_notequal: return f1 != f2 ? Qt : Qnil;
+ case arith_less: return f1 < f2 ? Qt : Qnil;
+ case arith_less_or_equal: return f1 <= f2 ? Qt : Qnil;
+ case arith_grtr: return f1 > f2 ? Qt : Qnil;
+ case arith_grtr_or_equal: return f1 >= f2 ? Qt : Qnil;
+ }
+ }
+#endif /* LISP_FLOAT_TYPE */
+
+ switch (comparison)
+ {
+ case arith_equal: return XINT (num1) == XINT (num2) ? Qt : Qnil;
+ case arith_notequal: return XINT (num1) != XINT (num2) ? Qt : Qnil;
+ case arith_less: return XINT (num1) < XINT (num2) ? Qt : Qnil;
+ case arith_less_or_equal: return XINT (num1) <= XINT (num2) ? Qt : Qnil;
+ case arith_grtr: return XINT (num1) > XINT (num2) ? Qt : Qnil;
+ case arith_grtr_or_equal: return XINT (num1) >= XINT (num2) ? Qt : Qnil;
}
+
+ abort ();
+ return Qnil; /* suppress compiler warning */
}
-#define ARITHCOMPARE_MANY(op) \
-{ \
- int_or_double iod1, iod2, *p = &iod1, *q = &iod2; \
- Lisp_Object *args_end = args + nargs; \
- \
- number_char_or_marker_to_int_or_double (*args++, p); \
- \
- while (args < args_end) \
- { \
- number_char_or_marker_to_int_or_double (*args++, q); \
- \
- if (!((p->int_p && q->int_p) ? \
- (p->c.ival op q->c.ival) : \
- ((p->int_p ? (double) p->c.ival : p->c.dval) op \
- (q->int_p ? (double) q->c.ival : q->c.dval)))) \
- return Qnil; \
- \
- { /* swap */ int_or_double *r = p; p = q; q = r; } \
- } \
- return Qt; \
+static Lisp_Object
+arithcompare_many (enum arith_comparison comparison,
+ int nargs, Lisp_Object *args)
+{
+ for (; --nargs > 0; args++)
+ if (NILP (arithcompare (*args, *(args + 1), comparison)))
+ return Qnil;
+
+ return Qt;
}
DEFUN ("=", Feqlsign, 1, MANY, 0, /*
*/
(int nargs, Lisp_Object *args))
{
- ARITHCOMPARE_MANY (==)
+ return arithcompare_many (arith_equal, nargs, args);
}
DEFUN ("<", Flss, 1, MANY, 0, /*
*/
(int nargs, Lisp_Object *args))
{
- ARITHCOMPARE_MANY (<)
+ return arithcompare_many (arith_less, nargs, args);
}
DEFUN (">", Fgtr, 1, MANY, 0, /*
*/
(int nargs, Lisp_Object *args))
{
- ARITHCOMPARE_MANY (>)
+ return arithcompare_many (arith_grtr, nargs, args);
}
DEFUN ("<=", Fleq, 1, MANY, 0, /*
*/
(int nargs, Lisp_Object *args))
{
- ARITHCOMPARE_MANY (<=)
+ return arithcompare_many (arith_less_or_equal, nargs, args);
}
DEFUN (">=", Fgeq, 1, MANY, 0, /*
*/
(int nargs, Lisp_Object *args))
{
- ARITHCOMPARE_MANY (>=)
+ return arithcompare_many (arith_grtr_or_equal, nargs, args);
}
DEFUN ("/=", Fneq, 1, MANY, 0, /*
*/
(int nargs, Lisp_Object *args))
{
- Lisp_Object *args_end = args + nargs;
- Lisp_Object *p, *q;
-
- /* Unlike all the other comparisons, this is an N*N algorithm.
- We could use a hash table for nargs > 50 to make this linear. */
- for (p = args; p < args_end; p++)
- {
- int_or_double iod1, iod2;
- number_char_or_marker_to_int_or_double (*p, &iod1);
-
- for (q = p + 1; q < args_end; q++)
- {
- number_char_or_marker_to_int_or_double (*q, &iod2);
-
- if (!((iod1.int_p && iod2.int_p) ?
- (iod1.c.ival != iod2.c.ival) :
- ((iod1.int_p ? (double) iod1.c.ival : iod1.c.dval) !=
- (iod2.int_p ? (double) iod2.c.ival : iod2.c.dval))))
- return Qnil;
- }
- }
- return Qt;
+ return arithcompare_many (arith_notequal, nargs, args);
}
DEFUN ("zerop", Fzerop, 1, 1, 0, /*
*/
(number))
{
- retry:
- if (INTP (number))
- return EQ (number, Qzero) ? Qt : Qnil;
+ CHECK_INT_OR_FLOAT (number);
+
#ifdef LISP_FLOAT_TYPE
- else if (FLOATP (number))
- return XFLOAT_DATA (number) == 0.0 ? Qt : Qnil;
+ if (FLOATP (number))
+ return float_data (XFLOAT (number)) == 0.0 ? Qt : Qnil;
#endif /* LISP_FLOAT_TYPE */
- else
- {
- number = wrong_type_argument (Qnumberp, number);
- goto retry;
- }
+
+ return EQ (number, Qzero) ? Qt : Qnil;
}
\f
/* Convert between a 32-bit value and a cons of two 16-bit values.
{
char pigbuf[350]; /* see comments in float_to_string */
- float_to_string (pigbuf, XFLOAT_DATA (num));
+ float_to_string (pigbuf, float_data (XFLOAT (num)));
return build_string (pigbuf);
}
#endif /* LISP_FLOAT_TYPE */
if (b == 10)
{
/* Use the system-provided functions for base 10. */
-#if SIZEOF_EMACS_INT == SIZEOF_INT
+#if SIZEOF_EMACS_INT == SIZEOF_INT
return make_int (atoi (p));
#elif SIZEOF_EMACS_INT == SIZEOF_LONG
return make_int (atol (p));
}
}
\f
+enum arithop
+ { Aadd, Asub, Amult, Adiv, Alogand, Alogior, Alogxor, Amax, Amin };
-DEFUN ("+", Fplus, 0, MANY, 0, /*
-Return sum of any number of arguments.
-The arguments should all be numbers, characters or markers.
-*/
- (int nargs, Lisp_Object *args))
-{
- EMACS_INT iaccum = 0;
- Lisp_Object *args_end = args + nargs;
-
- while (args < args_end)
- {
- int_or_double iod;
- number_char_or_marker_to_int_or_double (*args++, &iod);
- if (iod.int_p)
- iaccum += iod.c.ival;
- else
- {
- double daccum = (double) iaccum + iod.c.dval;
- while (args < args_end)
- daccum += number_char_or_marker_to_double (*args++);
- return make_float (daccum);
- }
- }
-
- return make_int (iaccum);
-}
-DEFUN ("-", Fminus, 1, MANY, 0, /*
-Negate number or subtract numbers, characters or markers.
-With one arg, negates it. With more than one arg,
-subtracts all but the first from the first.
-*/
- (int nargs, Lisp_Object *args))
+#ifdef LISP_FLOAT_TYPE
+static Lisp_Object
+float_arith_driver (double accum, int argnum, enum arithop code, int nargs,
+ Lisp_Object *args)
{
- EMACS_INT iaccum;
- double daccum;
- Lisp_Object *args_end = args + nargs;
- int_or_double iod;
+ REGISTER Lisp_Object val;
+ double next;
- number_char_or_marker_to_int_or_double (*args++, &iod);
- if (iod.int_p)
- iaccum = nargs > 1 ? iod.c.ival : - iod.c.ival;
- else
+ for (; argnum < nargs; argnum++)
{
- daccum = nargs > 1 ? iod.c.dval : - iod.c.dval;
- goto do_float;
- }
+ /* using args[argnum] as argument to CHECK_INT_OR_FLOAT_... */
+ val = args[argnum];
+ CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (val);
- while (args < args_end)
- {
- number_char_or_marker_to_int_or_double (*args++, &iod);
- if (iod.int_p)
- iaccum -= iod.c.ival;
- else
+ if (FLOATP (val))
{
- daccum = (double) iaccum - iod.c.dval;
- goto do_float;
+ next = float_data (XFLOAT (val));
}
- }
-
- return make_int (iaccum);
-
- do_float:
- for (; args < args_end; args++)
- daccum -= number_char_or_marker_to_double (*args);
- return make_float (daccum);
-}
-
-DEFUN ("*", Ftimes, 0, MANY, 0, /*
-Return product of any number of arguments.
-The arguments should all be numbers, characters or markers.
-*/
- (int nargs, Lisp_Object *args))
-{
- EMACS_INT iaccum = 1;
- Lisp_Object *args_end = args + nargs;
-
- while (args < args_end)
- {
- int_or_double iod;
- number_char_or_marker_to_int_or_double (*args++, &iod);
- if (iod.int_p)
- iaccum *= iod.c.ival;
else
{
- double daccum = (double) iaccum * iod.c.dval;
- while (args < args_end)
- daccum *= number_char_or_marker_to_double (*args++);
- return make_float (daccum);
+ args[argnum] = val; /* runs into a compiler bug. */
+ next = XINT (args[argnum]);
}
- }
-
- return make_int (iaccum);
-}
-
-DEFUN ("/", Fquo, 1, MANY, 0, /*
-Return first argument divided by all the remaining arguments.
-The arguments must be numbers, characters or markers.
-With one argument, reciprocates the argument.
-*/
- (int nargs, Lisp_Object *args))
-{
- EMACS_INT iaccum;
- double daccum;
- Lisp_Object *args_end = args + nargs;
- int_or_double iod;
-
- if (nargs == 1)
- iaccum = 1;
- else
- {
- number_char_or_marker_to_int_or_double (*args++, &iod);
- if (iod.int_p)
- iaccum = iod.c.ival;
- else
- {
- daccum = iod.c.dval;
- goto divide_floats;
- }
- }
-
- while (args < args_end)
- {
- number_char_or_marker_to_int_or_double (*args++, &iod);
- if (iod.int_p)
+ switch (code)
{
- if (iod.c.ival == 0) goto divide_by_zero;
- iaccum /= iod.c.ival;
- }
- else
- {
- if (iod.c.dval == 0) goto divide_by_zero;
- daccum = (double) iaccum / iod.c.dval;
- goto divide_floats;
+ 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_char_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_int (iaccum);
-
- divide_floats:
- for (; args < args_end; args++)
- {
- double dval = number_char_or_marker_to_double (*args);
- if (dval == 0) goto divide_by_zero;
- daccum /= dval;
- }
- return make_float (daccum);
-
- divide_by_zero:
- Fsignal (Qarith_error, Qnil);
- return Qnil; /* not reached */
+ return make_float (accum);
}
+#endif /* LISP_FLOAT_TYPE */
-DEFUN ("max", Fmax, 1, MANY, 0, /*
-Return largest of all the arguments.
-All arguments must be numbers, characters or markers.
-The value is always a number; markers and characters are converted
-to numbers.
-*/
- (int nargs, Lisp_Object *args))
+static Lisp_Object
+arith_driver (enum arithop code, int nargs, Lisp_Object *args)
{
- EMACS_INT imax;
- double dmax;
- Lisp_Object *args_end = args + nargs;
- int_or_double iod;
+ Lisp_Object val;
+ REGISTER int argnum;
+ REGISTER EMACS_INT accum = 0;
+ REGISTER EMACS_INT next;
- number_char_or_marker_to_int_or_double (*args++, &iod);
- if (iod.int_p)
- imax = iod.c.ival;
- else
+ switch (code)
{
- dmax = iod.c.dval;
- goto max_floats;
- }
-
- while (args < args_end)
- {
- number_char_or_marker_to_int_or_double (*args++, &iod);
- if (iod.int_p)
- {
- if (imax < iod.c.ival) imax = iod.c.ival;
- }
- else
- {
- dmax = (double) imax;
- if (dmax < iod.c.dval) dmax = iod.c.dval;
- goto max_floats;
- }
- }
-
- return make_int (imax);
-
- max_floats:
- while (args < args_end)
- {
- double dval = number_char_or_marker_to_double (*args++);
- if (dmax < dval) dmax = dval;
+ 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 ();
}
- return make_float (dmax);
-}
-
-DEFUN ("min", Fmin, 1, MANY, 0, /*
-Return smallest of all the arguments.
-All arguments must be numbers, characters or markers.
-The value is always a number; markers and characters are converted
-to numbers.
-*/
- (int nargs, Lisp_Object *args))
-{
- EMACS_INT imin;
- double dmin;
- Lisp_Object *args_end = args + nargs;
- int_or_double iod;
- number_char_or_marker_to_int_or_double (*args++, &iod);
- if (iod.int_p)
- imin = iod.c.ival;
- else
+ for (argnum = 0; argnum < nargs; argnum++)
{
- dmin = iod.c.dval;
- goto min_floats;
- }
+ /* using args[argnum] as argument to CHECK_INT_OR_FLOAT_... */
+ val = args[argnum];
+ CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (val);
- while (args < args_end)
- {
- number_char_or_marker_to_int_or_double (*args++, &iod);
- if (iod.int_p)
- {
- if (imin > iod.c.ival) imin = iod.c.ival;
- }
- else
+#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)
{
- dmin = (double) imin;
- if (dmin > iod.c.dval) dmin = iod.c.dval;
- goto min_floats;
+ 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;
}
}
- return make_int (imin);
-
- min_floats:
- while (args < args_end)
- {
- double dval = number_char_or_marker_to_double (*args++);
- if (dmin > dval) dmin = dval;
- }
- return make_float (dmin);
+ XSETINT (val, accum);
+ return val;
}
-DEFUN ("logand", Flogand, 0, MANY, 0, /*
-Return bitwise-and of all the arguments.
-Arguments may be integers, or markers or characters converted to integers.
+DEFUN ("+", Fplus, 0, MANY, 0, /*
+Return sum of any number of arguments.
+The arguments should all be numbers, characters or markers.
*/
(int nargs, Lisp_Object *args))
{
- EMACS_INT bits = ~0;
- Lisp_Object *args_end = args + nargs;
-
- while (args < args_end)
- bits &= integer_char_or_marker_to_int (*args++);
-
- return make_int (bits);
+ return arith_driver (Aadd, nargs, args);
}
-DEFUN ("logior", Flogior, 0, MANY, 0, /*
-Return bitwise-or of all the arguments.
-Arguments may be integers, or markers or characters converted to integers.
+DEFUN ("-", Fminus, 0, MANY, 0, /*
+Negate number or subtract numbers, characters or markers.
+With one arg, negates it. With more than one arg,
+subtracts all but the first from the first.
*/
(int nargs, Lisp_Object *args))
{
- EMACS_INT bits = 0;
- Lisp_Object *args_end = args + nargs;
-
- while (args < args_end)
- bits |= integer_char_or_marker_to_int (*args++);
-
- return make_int (bits);
+ return arith_driver (Asub, nargs, args);
}
-DEFUN ("logxor", Flogxor, 0, MANY, 0, /*
-Return bitwise-exclusive-or of all the arguments.
-Arguments may be integers, or markers or characters converted to integers.
+DEFUN ("*", Ftimes, 0, MANY, 0, /*
+Return product of any number of arguments.
+The arguments should all be numbers, characters or markers.
*/
(int nargs, Lisp_Object *args))
{
- EMACS_INT bits = 0;
- Lisp_Object *args_end = args + nargs;
-
- while (args < args_end)
- bits ^= integer_char_or_marker_to_int (*args++);
-
- return make_int (bits);
+ return arith_driver (Amult, nargs, args);
}
-DEFUN ("lognot", Flognot, 1, 1, 0, /*
-Return the bitwise complement of NUMBER.
-NUMBER may be an integer, marker or character converted to integer.
+DEFUN ("/", Fquo, 2, MANY, 0, /*
+Return first argument divided by all the remaining arguments.
+The arguments must be numbers, characters or markers.
*/
- (number))
+ (int nargs, Lisp_Object *args))
{
- return make_int (~ integer_char_or_marker_to_int (number));
+ return arith_driver (Adiv, nargs, args);
}
DEFUN ("%", Frem, 2, 2, 0, /*
*/
(num1, num2))
{
- EMACS_INT ival1 = integer_char_or_marker_to_int (num1);
- EMACS_INT ival2 = integer_char_or_marker_to_int (num2);
+ CHECK_INT_COERCE_CHAR_OR_MARKER (num1);
+ CHECK_INT_COERCE_CHAR_OR_MARKER (num2);
- if (ival2 == 0)
+ if (ZEROP (num2))
Fsignal (Qarith_error, Qnil);
- return make_int (ival1 % ival2);
+ return make_int (XINT (num1) % XINT (num2));
}
/* Note, ANSI *requires* the presence of the fmod() library routine.
*/
(x, y))
{
- int_or_double iod1, iod2;
- number_char_or_marker_to_int_or_double (x, &iod1);
- number_char_or_marker_to_int_or_double (y, &iod2);
+ EMACS_INT i1, i2;
#ifdef LISP_FLOAT_TYPE
- if (!iod1.int_p || !iod2.int_p)
+ CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (x);
+ CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (y);
+
+ if (FLOATP (x) || FLOATP (y))
{
- double dval1 = iod1.int_p ? (double) iod1.c.ival : iod1.c.dval;
- double dval2 = iod2.int_p ? (double) iod2.c.ival : iod2.c.dval;
- if (dval2 == 0) goto divide_by_zero;
- dval1 = fmod (dval1, dval2);
+ double f1, f2;
- /* If the "remainder" comes out with the wrong sign, fix it. */
- if (dval2 < 0 ? dval1 > 0 : dval1 < 0)
- dval1 += dval2;
+ 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);
- return make_float (dval1);
+ /* If the "remainder" comes out with the wrong sign, fix it. */
+ if (f2 < 0 ? f1 > 0 : f1 < 0)
+ f1 += f2;
+ return make_float (f1);
}
-#endif /* LISP_FLOAT_TYPE */
- {
- EMACS_INT ival;
- if (iod2.c.ival == 0) goto divide_by_zero;
+#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 */
- ival = iod1.c.ival % iod2.c.ival;
+ i1 = XINT (x);
+ i2 = XINT (y);
- /* If the "remainder" comes out with the wrong sign, fix it. */
- if (iod2.c.ival < 0 ? ival > 0 : ival < 0)
- ival += iod2.c.ival;
+ if (i2 == 0)
+ Fsignal (Qarith_error, Qnil);
- return make_int (ival);
- }
+ i1 %= i2;
- divide_by_zero:
- Fsignal (Qarith_error, Qnil);
- return Qnil; /* not reached */
+ /* 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, 1, MANY, 0, /*
+Return largest of all the arguments.
+All arguments must be numbers, characters or markers.
+The value is always a number; markers and characters are converted
+to numbers.
+*/
+ (int nargs, Lisp_Object *args))
+{
+ return arith_driver (Amax, nargs, args);
+}
+
+DEFUN ("min", Fmin, 1, MANY, 0, /*
+Return smallest of all the arguments.
+All arguments must be numbers, characters or markers.
+The value is always a number; markers and characters are converted
+to numbers.
+*/
+ (int nargs, Lisp_Object *args))
+{
+ return arith_driver (Amin, nargs, args);
+}
+
+DEFUN ("logand", Flogand, 0, MANY, 0, /*
+Return bitwise-and of all the arguments.
+Arguments may be integers, or markers or characters converted to integers.
+*/
+ (int nargs, Lisp_Object *args))
+{
+ return arith_driver (Alogand, nargs, args);
+}
+
+DEFUN ("logior", Flogior, 0, MANY, 0, /*
+Return bitwise-or of all the arguments.
+Arguments may be integers, or markers or characters converted to integers.
+*/
+ (int nargs, Lisp_Object *args))
+{
+ return arith_driver (Alogior, nargs, args);
+}
+
+DEFUN ("logxor", Flogxor, 0, MANY, 0, /*
+Return bitwise-exclusive-or of all the arguments.
+Arguments may be integers, or markers or characters converted to integers.
+*/
+ (int nargs, Lisp_Object *args))
+{
+ return arith_driver (Alogxor, nargs, args);
}
DEFUN ("ash", Fash, 2, 2, 0, /*
(value, count))
{
CHECK_INT_COERCE_CHAR (value);
- CONCHECK_INT (count);
+ CHECK_INT (count);
return make_int (XINT (count) > 0 ?
XINT (value) << XINT (count) :
(value, count))
{
CHECK_INT_COERCE_CHAR (value);
- CONCHECK_INT (count);
+ CHECK_INT (count);
return make_int (XINT (count) > 0 ?
XUINT (value) << XINT (count) :
}
DEFUN ("1+", Fadd1, 1, 1, 0, /*
-Return NUMBER plus one. NUMBER may be a number, character or marker.
+Return NUMBER plus one. NUMBER may be a number or a marker.
Markers and characters are converted to integers.
*/
(number))
{
- retry:
+ CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (number);
- if (INTP (number)) return make_int (XINT (number) + 1);
- if (CHARP (number)) return make_int (XCHAR (number) + 1);
- if (MARKERP (number)) return make_int (marker_position (number) + 1);
#ifdef LISP_FLOAT_TYPE
- if (FLOATP (number)) return make_float (XFLOAT_DATA (number) + 1.0);
+ if (FLOATP (number))
+ return make_float (1.0 + float_data (XFLOAT (number)));
#endif /* LISP_FLOAT_TYPE */
- number = wrong_type_argument (Qnumber_char_or_marker_p, number);
- goto retry;
+ return make_int (XINT (number) + 1);
}
DEFUN ("1-", Fsub1, 1, 1, 0, /*
-Return NUMBER minus one. NUMBER may be a number, character or marker.
+Return NUMBER minus one. NUMBER may be a number or a marker.
Markers and characters are converted to integers.
*/
(number))
{
- retry:
+ CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (number);
- if (INTP (number)) return make_int (XINT (number) - 1);
- if (CHARP (number)) return make_int (XCHAR (number) - 1);
- if (MARKERP (number)) return make_int (marker_position (number) - 1);
#ifdef LISP_FLOAT_TYPE
- if (FLOATP (number)) return make_float (XFLOAT_DATA (number) - 1.0);
+ if (FLOATP (number))
+ return make_float (-1.0 + (float_data (XFLOAT (number))));
#endif /* LISP_FLOAT_TYPE */
- number = wrong_type_argument (Qnumber_char_or_marker_p, number);
- goto retry;
+ return make_int (XINT (number) - 1);
+}
+
+DEFUN ("lognot", Flognot, 1, 1, 0, /*
+Return the bitwise complement of NUMBER. NUMBER must be an integer.
+*/
+ (number))
+{
+ CHECK_INT (number);
+ return make_int (~XINT (number));
}
\f
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 hash tables; see the explanation
+ remove them. This is analogous to weak hashtables; see the explanation
there for more info. */
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)
+mark_weak_list (Lisp_Object obj, void (*markobj) (Lisp_Object))
{
return Qnil; /* nichts ist gemarkt */
}
}
static int
-weak_list_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
+weak_list_equal (Lisp_Object o1, Lisp_Object o2, int depth)
{
- struct weak_list *w1 = XWEAK_LIST (obj1);
- struct weak_list *w2 = XWEAK_LIST (obj2);
+ struct weak_list *w1 = XWEAK_LIST (o1);
+ struct weak_list *w2 = XWEAK_LIST (o2);
return ((w1->type == w2->type) &&
internal_equal (w1->list, w2->list, depth + 1));
{
Lisp_Object result;
struct weak_list *wl =
- alloc_lcrecord_type (struct weak_list, &lrecord_weak_list);
+ alloc_lcrecord_type (struct weak_list, lrecord_weak_list);
wl->list = Qnil;
wl->type = type;
return result;
}
-static const struct lrecord_description weak_list_description[] = {
- { XD_LISP_OBJECT, offsetof (struct weak_list, list) },
- { XD_LO_LINK, offsetof (struct weak_list, next_weak) },
- { XD_END }
-};
-
DEFINE_LRECORD_IMPLEMENTATION ("weak-list", weak_list,
mark_weak_list, print_weak_list,
0, weak_list_equal, weak_list_hash,
- weak_list_description,
struct weak_list);
/*
-- we do not mark the list elements (either the elements themselves
*/
int
-finish_marking_weak_lists (void)
+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;
- !NILP (rest);
+ !GC_NILP (rest);
rest = XWEAK_LIST (rest)->next_weak)
{
Lisp_Object rest2;
enum weak_list_type type = XWEAK_LIST (rest)->type;
- if (! marked_p (rest))
+ if (! ((*obj_marked_p) (rest)))
/* The weak list is probably garbage. Ignore it. */
continue;
/* We need to be trickier since we're inside of GC;
use CONSP instead of !NILP in case of user-visible
imperfect lists */
- CONSP (rest2);
+ GC_CONSP (rest2);
rest2 = XCDR (rest2))
{
Lisp_Object elem;
(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 (marked_p (rest2))
+ if ((*obj_marked_p) (rest2))
break;
elem = XCAR (rest2);
switch (type)
{
case WEAK_LIST_SIMPLE:
- if (marked_p (elem))
+ if ((*obj_marked_p) (elem))
need_to_mark_cons = 1;
break;
case WEAK_LIST_ASSOC:
- if (!CONSP (elem))
+ if (!GC_CONSP (elem))
{
/* just leave bogus elements there */
need_to_mark_cons = 1;
need_to_mark_elem = 1;
}
- else if (marked_p (XCAR (elem)) &&
- marked_p (XCDR (elem)))
+ 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
break;
case WEAK_LIST_KEY_ASSOC:
- if (!CONSP (elem))
+ if (!GC_CONSP (elem))
{
/* just leave bogus elements there */
need_to_mark_cons = 1;
need_to_mark_elem = 1;
}
- else if (marked_p (XCAR (elem)))
+ else if ((*obj_marked_p) (XCAR (elem)))
{
need_to_mark_cons = 1;
/* We still need to mark elem and XCDR (elem);
break;
case WEAK_LIST_VALUE_ASSOC:
- if (!CONSP (elem))
+ if (!GC_CONSP (elem))
{
/* just leave bogus elements there */
need_to_mark_cons = 1;
need_to_mark_elem = 1;
}
- else if (marked_p (XCDR (elem)))
+ else if ((*obj_marked_p) (XCDR (elem)))
{
need_to_mark_cons = 1;
/* We still need to mark elem and XCAR (elem);
abort ();
}
- if (need_to_mark_elem && ! marked_p (elem))
+ if (need_to_mark_elem && ! (*obj_marked_p) (elem))
{
- mark_object (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 (mark_object) here
+ 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)
{
- Lisp_Cons *c = XCONS (rest2);
- if (!CONS_MARKED_P (c))
+ struct Lisp_Cons *ptr = XCONS (rest2);
+ if (!CONS_MARKED_P (ptr))
{
- MARK_CONS (c);
+ MARK_CONS (ptr);
did_mark = 1;
}
}
/* In case of imperfect list, need to mark the final cons
because we're not removing it */
- if (!NILP (rest2) && ! marked_p (rest2))
+ if (!GC_NILP (rest2) && ! (obj_marked_p) (rest2))
{
- mark_object (rest2);
+ (markobj) (rest2);
did_mark = 1;
}
}
}
void
-prune_weak_lists (void)
+prune_weak_lists (int (*obj_marked_p) (Lisp_Object))
{
Lisp_Object rest, prev = Qnil;
for (rest = Vall_weak_lists;
- !NILP (rest);
+ !GC_NILP (rest);
rest = XWEAK_LIST (rest)->next_weak)
{
- if (! (marked_p (rest)))
+ if (! ((*obj_marked_p) (rest)))
{
/* This weak list itself is garbage. Remove it from the list. */
- if (NILP (prev))
+ if (GC_NILP (prev))
Vall_weak_lists = XWEAK_LIST (rest)->next_weak;
else
XWEAK_LIST (prev)->next_weak =
/* We need to be trickier since we're inside of GC;
use CONSP instead of !NILP in case of user-visible
imperfect lists */
- CONSP (rest2);)
+ GC_CONSP (rest2);)
{
/* It suffices to check the cons for marking,
regardless of the type of weak list:
have been marked in finish_marking_weak_lists().
-- otherwise, it's not marked and should disappear.
*/
- if (! marked_p (rest2))
+ if (!(*obj_marked_p) (rest2))
{
/* bye bye :-( */
- if (NILP (prev2))
+ if (GC_NILP (prev2))
XWEAK_LIST (rest)->list = XCDR (rest2);
else
XCDR (prev2) = XCDR (rest2);
if (go_tortoise)
tortoise = XCDR (tortoise);
go_tortoise = !go_tortoise;
- if (EQ (rest2, tortoise))
+ if (GC_EQ (rest2, tortoise))
break;
}
}
"Attempt to set a constant symbol", Qerror);
deferror (&Qinvalid_read_syntax, "invalid-read-syntax",
"Invalid read syntax", Qerror);
-
- /* Generated by list traversal macros */
deferror (&Qmalformed_list, "malformed-list",
"Malformed list", Qerror);
deferror (&Qmalformed_property_list, "malformed-property-list",
- "Malformed property list", Qmalformed_list);
+ "Malformed property list", Qerror);
deferror (&Qcircular_list, "circular-list",
"Circular list", Qerror);
deferror (&Qcircular_property_list, "circular-property-list",
- "Circular property list", Qcircular_list);
-
+ "Circular property list", Qerror);
deferror (&Qinvalid_function, "invalid-function", "Invalid function",
Qerror);
deferror (&Qwrong_number_of_arguments, "wrong-number-of-arguments",
void
syms_of_data (void)
{
+ defsymbol (&Qcons, "cons");
+ defsymbol (&Qkeyword, "keyword");
defsymbol (&Qquote, "quote");
defsymbol (&Qlambda, "lambda");
+ defsymbol (&Qignore, "ignore");
defsymbol (&Qlistp, "listp");
defsymbol (&Qtrue_list_p, "true-list-p");
defsymbol (&Qconsp, "consp");
defsymbol (&Qsubrp, "subrp");
defsymbol (&Qsymbolp, "symbolp");
+ defsymbol (&Qkeywordp, "keywordp");
defsymbol (&Qintegerp, "integerp");
defsymbol (&Qcharacterp, "characterp");
defsymbol (&Qnatnump, "natnump");
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");
defsymbol (&Qinteger_or_char_p, "integer-or-char-p");
defsymbol (&Qinteger_char_or_marker_p, "integer-char-or-marker-p");
defsymbol (&Qnumberp, "numberp");
+ defsymbol (&Qnumber_or_marker_p, "number-or-marker-p");
defsymbol (&Qnumber_char_or_marker_p, "number-char-or-marker-p");
defsymbol (&Qcdr, "cdr");
defsymbol (&Qweak_listp, "weak-list-p");
DEFSUBR (Feq);
DEFSUBR (Fold_eq);
DEFSUBR (Fnull);
- Ffset (intern ("not"), intern ("null"));
DEFSUBR (Flistp);
DEFSUBR (Fnlistp);
DEFSUBR (Ftrue_list_p);
DEFSUBR (Fsubr_min_args);
DEFSUBR (Fsubr_max_args);
DEFSUBR (Fsubr_interactive);
+ DEFSUBR (Fcompiled_function_p);
DEFSUBR (Ftype_of);
DEFSUBR (Fcar);
DEFSUBR (Fcdr);
DEFSUBR (Faref);
DEFSUBR (Faset);
+ DEFSUBR (Fcompiled_function_instructions);
+ DEFSUBR (Fcompiled_function_constants);
+ DEFSUBR (Fcompiled_function_stack_depth);
+ DEFSUBR (Fcompiled_function_arglist);
+ DEFSUBR (Fcompiled_function_interactive);
+ DEFSUBR (Fcompiled_function_doc_string);
+ DEFSUBR (Fcompiled_function_domain);
+#ifdef COMPILED_FUNCTION_ANNOTATION_HACK
+ DEFSUBR (Fcompiled_function_annotation);
+#endif
+
DEFSUBR (Fnumber_to_string);
DEFSUBR (Fstring_to_number);
DEFSUBR (Feqlsign);
{
/* This must not be staticpro'd */
Vall_weak_lists = Qnil;
- pdump_wire_list (&Vall_weak_lists);
#ifdef DEBUG_XEMACS
- DEFVAR_BOOL ("debug-issue-ebola-notices", &debug_issue_ebola_notices /*
-If non-zero, note when your code may be suffering from char-int confoundance.
+ DEFVAR_INT ("debug-issue-ebola-notices", &debug_issue_ebola_notices /*
+If non-nil, note when your code may be suffering from char-int confoundance.
That is to say, if XEmacs encounters a usage of `eq', `memq', `equal',
-etc. where an int and a char with the same value are being compared,
+etc. where a int and a char with the same value are being compared,
it will issue a notice on stderr to this effect, along with a backtrace.
In such situations, the result would be different in XEmacs 19 versus
XEmacs 20, and you probably don't want this.
impossible to accurately determine Ebola infection.
*/ );
- debug_issue_ebola_notices = 0;
+ debug_issue_ebola_notices = 2; /* #### temporary hack */
DEFVAR_INT ("debug-ebola-backtrace-length",
&debug_ebola_backtrace_length /*
projects / chise / xemacs-chise.git.1 / blobdiff