1 /* Primitive operations on Lisp data types for SXEmacs Lisp interpreter.
2 Copyright (C) 1985, 1986, 1988, 1992, 1993, 1994, 1995
3 Free Software Foundation, Inc.
4 Copyright (C) 2000 Ben Wing.
6 This file is part of SXEmacs
8 SXEmacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 SXEmacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with this program. If not, see <http://www.gnu.org/licenses/>. */
22 /* Synched up with: Mule 2.0, FSF 19.30. Some of FSF's data.c is in
23 SXEmacs' symbols.c. */
25 /* This file has been Mule-ized. */
32 #include "syssignal.h"
36 Lisp_Object Qnil, Qt, Qquote, Qlambda, Qunbound;
37 Lisp_Object Qerror_conditions, Qerror_message;
38 Lisp_Object Qerror, Qquit, Qsyntax_error, Qinvalid_read_syntax;
39 Lisp_Object Qlist_formation_error, Qstructure_formation_error;
40 Lisp_Object Qmalformed_list, Qmalformed_property_list;
41 Lisp_Object Qcircular_list, Qcircular_property_list;
42 Lisp_Object Qinvalid_argument, Qwrong_type_argument, Qargs_out_of_range;
43 Lisp_Object Qwrong_number_of_arguments, Qinvalid_function, Qno_catch;
44 Lisp_Object Qinternal_error, Qinvalid_state, Qinvalid_constant;
45 Lisp_Object Qvoid_variable, Qcyclic_variable_indirection;
46 Lisp_Object Qvoid_function, Qcyclic_function_indirection;
47 Lisp_Object Qinvalid_operation, Qinvalid_change, Qout_of_memory;
48 Lisp_Object Qsetting_constant, Qprinting_unreadable_object;
49 Lisp_Object Qediting_error, Qconversion_error, Qtext_conversion_error;
50 Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only;
51 Lisp_Object Qio_error, Qend_of_file;
52 Lisp_Object Qarith_error, Qrange_error, Qdomain_error, Qstack_overflow;
53 Lisp_Object Qsingularity_error, Qoverflow_error, Qunderflow_error;
54 Lisp_Object Qintegerp, Qnatnump, Qnonnegativep, Qpositivep, Qsymbolp;
55 Lisp_Object Qlistp, Qtrue_list_p, Qweak_listp;
56 Lisp_Object Qconsp, Qsubrp;
57 Lisp_Object Qcharacterp, Qstringp, Qarrayp, Qsequencep, Qvectorp, Qdictp;
58 Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qbufferp;
59 Lisp_Object Qinteger_or_char_p, Qinteger_char_or_marker_p;
60 Lisp_Object Qnumberp, Qnumber_char_or_marker_p;
61 Lisp_Object Qbit_vectorp, Qbitp, Qcdr;
67 int debug_issue_ebola_notices;
69 Fixnum debug_ebola_backtrace_length;
71 int eq_with_ebola_notice(Lisp_Object obj1, Lisp_Object obj2)
73 if (debug_issue_ebola_notices
74 && ((CHARP(obj1) && INTP(obj2)) || (CHARP(obj2) && INTP(obj1)))) {
75 /* #### It would be really nice if this were a proper warning
76 instead of brain-dead print to Qexternal_debugging_output. */
78 ("Comparison between integer and character is constant nil (",
79 Qexternal_debugging_output);
80 Fprinc(obj1, Qexternal_debugging_output);
81 write_c_string(" and ", Qexternal_debugging_output);
82 Fprinc(obj2, Qexternal_debugging_output);
83 write_c_string(")\n", Qexternal_debugging_output);
84 debug_short_backtrace(debug_ebola_backtrace_length);
86 return EQ(obj1, obj2);
89 #endif /* DEBUG_SXEMACS */
91 Lisp_Object wrong_type_argument(Lisp_Object predicate, Lisp_Object value)
93 /* This function can GC */
94 REGISTER Lisp_Object tem;
96 value = Fsignal(Qwrong_type_argument, list2(predicate, value));
97 tem = call1(predicate, value);
103 DOESNT_RETURN dead_wrong_type_argument(Lisp_Object predicate, Lisp_Object value)
105 signal_error(Qwrong_type_argument, list2(predicate, value));
108 DEFUN("wrong-type-argument", Fwrong_type_argument, 2, 2, 0, /*
109 Signal an error until the correct type value is given by the user.
110 This function loops, signalling a continuable `wrong-type-argument' error
111 with PREDICATE and VALUE as the data associated with the error and then
112 calling PREDICATE on the returned value, until the value gotten satisfies
113 PREDICATE. At that point, the gotten value is returned.
117 return wrong_type_argument(predicate, value);
120 DOESNT_RETURN c_write_error(Lisp_Object obj)
122 signal_simple_error("Attempt to modify read-only object (c)", obj);
125 DOESNT_RETURN lisp_write_error(Lisp_Object obj)
127 signal_simple_error("Attempt to modify read-only object (lisp)", obj);
130 DOESNT_RETURN args_out_of_range(Lisp_Object a1, Lisp_Object a2)
132 signal_error(Qargs_out_of_range, list2(a1, a2));
136 args_out_of_range_3(Lisp_Object a1, Lisp_Object a2, Lisp_Object a3)
138 signal_error(Qargs_out_of_range, list3(a1, a2, a3));
141 void check_int_range(EMACS_INT val, EMACS_INT min, EMACS_INT max)
143 if (val < min || val > max)
144 args_out_of_range_3(make_int(val), make_int(min),
148 /* On some machines, XINT needs a temporary location.
149 Here it is, in case it is needed. */
151 EMACS_INT sign_extend_temp;
153 /* On a few machines, XINT can only be done by calling this. */
154 /* SXEmacs: only used by m/convex.h */
155 EMACS_INT sign_extend_lisp_int(EMACS_INT num);
156 EMACS_INT sign_extend_lisp_int(EMACS_INT num)
158 if (num & (1L << (INT_VALBITS - 1)))
159 return num | ((-1L) << INT_VALBITS);
161 return num & (EMACS_INT) ((1UL << INT_VALBITS) - 1);
164 /* Data type predicates */
166 DEFUN("eq", Feq, 2, 2, 0, /*
167 Return t if the two args are the same Lisp object.
171 return EQ_WITH_EBOLA_NOTICE(object1, object2) ? Qt : Qnil;
174 DEFUN("old-eq", Fold_eq, 2, 2, 0, /*
175 Return t if the two args are (in most cases) the same Lisp object.
177 Special kludge: A character is considered `old-eq' to its equivalent integer
178 even though they are not the same object and are in fact of different
179 types. This is ABSOLUTELY AND UTTERLY HORRENDOUS but is necessary to
180 preserve byte-code compatibility with v19. This kludge is known as the
181 \"char-int confoundance disease\" and appears in a number of other
182 functions with `old-foo' equivalents.
184 Do not use this function!
189 return HACKEQ_UNSAFE(object1, object2) ? Qt : Qnil;
192 DEFUN("null", Fnull, 1, 1, 0, /*
193 Return t if OBJECT is nil.
197 return NILP(object) ? Qt : Qnil;
200 DEFUN("consp", Fconsp, 1, 1, 0, /*
201 Return t if OBJECT is a cons cell. `nil' is not a cons cell.
203 A cons cell is a Lisp object (an area in memory) comprising two pointers
204 called the CAR and the CDR. Each of these pointers can point to any other
205 Lisp object. The common Lisp data type, the list, is a specially-structured
206 series of cons cells.
208 See the documentation for `cons' or the Lisp manual for more details on what
213 return CONSP(object) ? Qt : Qnil;
216 DEFUN("atom", Fatom, 1, 1, 0, /*
217 Return t if OBJECT is not a cons cell. `nil' is not a cons cell.
219 A cons cell is a Lisp object (an area in memory) comprising two pointers
220 called the CAR and the CDR. Each of these pointers can point to any other
221 Lisp object. The common Lisp data type, the list, is a specially-structured
222 series of cons cells.
224 See the documentation for `cons' or the Lisp manual for more details on what
229 return CONSP(object) ? Qnil : Qt;
232 DEFUN("listp", Flistp, 1, 1, 0, /*
233 Return t if OBJECT is a list. `nil' is a list.
235 A list is implemented as a series of cons cells structured such that the CDR
236 of each cell either points to another cons cell or to `nil', the special
237 Lisp value for both Boolean false and the empty list.
241 return LISTP(object) ? Qt : Qnil;
244 DEFUN("nlistp", Fnlistp, 1, 1, 0, /*
245 Return t if OBJECT is not a list. `nil' is a list.
247 A list is implemented as a series of cons cells structured such that the CDR
248 of each cell either points to another cons cell or to `nil', the special
249 Lisp value for both Boolean false and the empty list.
253 return LISTP(object) ? Qnil : Qt;
256 DEFUN("true-list-p", Ftrue_list_p, 1, 1, 0, /*
257 Return t if OBJECT is an acyclic, nil-terminated (ie, not dotted), list.
259 A list is implemented as a series of cons cells structured such that the CDR
260 of each cell either points to another cons cell or to `nil', the special
261 Lisp value for both Boolean false and the empty list.
265 return TRUE_LIST_P(object) ? Qt : Qnil;
268 DEFUN("symbolp", Fsymbolp, 1, 1, 0, /*
269 Return t if OBJECT is a symbol.
273 return SYMBOLP(object) ? Qt : Qnil;
276 DEFUN("keywordp", Fkeywordp, 1, 1, 0, /*
277 Return t if OBJECT is a keyword.
279 A symbol is a Lisp object with a name. It can optionally have any and all of
280 a value, a property list and an associated function.
284 return KEYWORDP(object) ? Qt : Qnil;
287 DEFUN("vectorp", Fvectorp, 1, 1, 0, /*
288 Return t if OBJECT is a vector.
292 return VECTORP(object) ? Qt : Qnil;
295 DEFUN("bit-vector-p", Fbit_vector_p, 1, 1, 0, /*
296 Return t if OBJECT is a bit vector.
300 return BIT_VECTORP(object) ? Qt : Qnil;
303 DEFUN("stringp", Fstringp, 1, 1, 0, /*
304 Return t if OBJECT is a string.
308 return STRINGP(object) ? Qt : Qnil;
311 DEFUN("arrayp", Farrayp, 1, 1, 0, /*
312 Return t if OBJECT is an array (string, vector, or bit vector).
316 return (VECTORP(object) || STRINGP(object) || BIT_VECTORP(object))
320 DEFUN("sequencep", Fsequencep, 1, 1, 0, /*
321 Return t if OBJECT is a sequence (list, dllist or array).
325 return (LISTP(object) || DLLISTP(object) ||
326 VECTORP(object) || STRINGP(object) || BIT_VECTORP(object))
330 DEFUN("markerp", Fmarkerp, 1, 1, 0, /*
331 Return t if OBJECT is a marker (editor pointer).
335 return MARKERP(object) ? Qt : Qnil;
338 DEFUN("subrp", Fsubrp, 1, 1, 0, /*
339 Return t if OBJECT is a built-in function.
343 return SUBRP(object) ? Qt : Qnil;
346 DEFUN("subr-min-args", Fsubr_min_args, 1, 1, 0, /*
347 Return minimum number of args built-in function SUBR may be called with.
352 return make_int(XSUBR(subr)->min_args);
355 DEFUN("subr-max-args", Fsubr_max_args, 1, 1, 0, /*
356 Return maximum number of args built-in function SUBR may be called with,
357 or nil if it takes an arbitrary number of arguments or is a special form.
363 nargs = XSUBR(subr)->max_args;
364 if (nargs == MANY || nargs == UNEVALLED)
367 return make_int(nargs);
370 DEFUN("subr-interactive", Fsubr_interactive, 1, 1, 0, /*
371 Return the interactive spec of the subr object SUBR, or nil.
372 If non-nil, the return value will be a list whose first element is
373 `interactive' and whose second element is the interactive spec.
379 prompt = XSUBR(subr)->prompt;
380 return prompt ? list2(Qinteractive, build_string(prompt)) : Qnil;
383 DEFUN("characterp", Fcharacterp, 1, 1, 0, /*
384 Return t if OBJECT is a character.
385 Unlike in XEmacs v19 and FSF Emacs, a character is its own primitive type.
386 Any character can be converted into an equivalent integer using
387 `char-int'. To convert the other way, use `int-char'; however,
388 only some integers can be converted into characters. Such an integer
389 is called a `char-int'; see `char-int-p'.
391 Some functions that work on integers (e.g. the comparison functions
392 <, <=, =, /=, etc. and the arithmetic functions +, -, *, etc.)
393 accept characters and implicitly convert them into integers. In
394 general, functions that work on characters also accept char-ints and
395 implicitly convert them into characters. WARNING: Neither of these
396 behaviors is very desirable, and they are maintained for backward
397 compatibility with old E-Lisp programs that confounded characters and
398 integers willy-nilly. These behaviors may change in the future; therefore,
399 do not rely on them. Instead, use the character-specific functions such
404 return CHARP(object) ? Qt : Qnil;
407 DEFUN("char-to-int", Fchar_to_int, 1, 1, 0, /*
408 Convert CHARACTER into an equivalent integer.
409 The resulting integer will always be non-negative. The integers in
410 the range 0 - 255 map to characters as follows:
414 128 - 159 Control set 1
415 160 - 255 Right half of ISO-8859-1
417 If support for Mule does not exist, these are the only valid character
418 values. When Mule support exists, the values assigned to other characters
419 may vary depending on the particular version of SXEmacs, the order in which
420 character sets were loaded, etc., and you should not depend on them.
424 CHECK_CHAR(character);
425 return make_int(XCHAR(character));
428 DEFUN("int-to-char", Fint_to_char, 1, 1, 0, /*
429 Convert integer INTEGER into the equivalent character.
430 Not all integers correspond to valid characters; use `char-int-p' to
431 determine whether this is the case. If the integer cannot be converted,
437 if (CHAR_INTP(integer))
438 return make_char(XINT(integer));
443 DEFUN("char-int-p", Fchar_int_p, 1, 1, 0, /*
444 Return t if OBJECT is an integer that can be converted into a character.
449 return CHAR_INTP(object) ? Qt : Qnil;
452 DEFUN("char-or-char-int-p", Fchar_or_char_int_p, 1, 1, 0, /*
453 Return t if OBJECT is a character or an integer that can be converted into one.
457 return CHAR_OR_CHAR_INTP(object) ? Qt : Qnil;
460 DEFUN("char-or-string-p", Fchar_or_string_p, 1, 1, 0, /*
461 Return t if OBJECT is a character (or a char-int) or a string.
462 It is semi-hateful that we allow a char-int here, as it goes against
463 the name of this function, but it makes the most sense considering the
464 other steps we take to maintain compatibility with the old character/integer
465 confoundedness in older versions of E-Lisp.
469 return CHAR_OR_CHAR_INTP(object) || STRINGP(object) ? Qt : Qnil;
472 #ifdef WITH_NUMBER_TYPES
473 /* In this case, integerp is defined in number.c. */
474 DEFUN("intp", Fintp, 1, 1, 0, /*
475 Return t if OBJECT is an ordinary integer.
479 return INTP(object) ? Qt : Qnil;
481 /* stay compatible to XE 21.5 */
482 DEFUN("fixnump", Ffixnump, 1, 1, 0, /*
483 Return t if OBJECT is an ordinary integer.
487 return INTP(object) ? Qt : Qnil;
489 #else /* !WITH_NUMBER_TYPES */
490 DEFUN("integerp", Fintegerp, 1, 1, 0, /*
491 Return t if OBJECT is an integer.
495 return INTP(object) ? Qt : Qnil;
497 #endif /* WITH_NUMBER_TYPES */
499 DEFUN("integer-or-marker-p", Finteger_or_marker_p, 1, 1, 0, /*
500 Return t if OBJECT is an integer or a marker (editor pointer).
504 return INTP(object) || MARKERP(object) ? Qt : Qnil;
507 DEFUN("integer-or-char-p", Finteger_or_char_p, 1, 1, 0, /*
508 Return t if OBJECT is an integer or a character.
512 return INTP(object) || CHARP(object) ? Qt : Qnil;
515 DEFUN("integer-char-or-marker-p", Finteger_char_or_marker_p, 1, 1, 0, /*
516 Return t if OBJECT is an integer, character or a marker (editor pointer).
520 return INTP(object) || CHARP(object) || MARKERP(object) ? Qt : Qnil;
523 DEFUN("natnump", Fnatnump, 1, 1, 0, /*
524 Return t if OBJECT is a nonnegative integer.
528 return (NATNUMP(object)
529 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
531 bigz_sign(XBIGZ_DATA(object)) >= 0)
536 DEFUN ("nonnegativep", Fnonnegativep, 1, 1, 0, /*
537 Return t if OBJECT is a nonnegative number.
539 We call a number object non-negative iff it is comparable
540 and its value is not less than 0.
544 return NATNUMP(object)
545 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
547 bigz_sign(XBIGZ_DATA(object)) >= 0)
548 #endif /* HAVE_MPZ */
549 #if defined HAVE_MPQ && defined WITH_GMP
551 bigq_sign(XBIGQ_DATA(object)) >= 0)
552 #endif /* HAVE_MPQ */
554 || (FLOATP(object) &&
555 (double)XFLOAT_DATA(object) >= 0.0)
556 #endif /* HAVE_FPFLOAT */
557 #if defined HAVE_MPF && defined WITH_GMP
559 bigf_sign(XBIGF_DATA(object)) >= 0)
560 #endif /* HAVE_MPF */
561 #if defined HAVE_MPFR && defined WITH_MPFR
562 || (BIGFRP(object) &&
563 bigfr_sign(XBIGFR_DATA(object)) >= 0)
564 #endif /* HAVE_MPFR */
568 DEFUN("bitp", Fbitp, 1, 1, 0, /*
569 Return t if OBJECT is a bit (0 or 1).
573 return BITP(object) ? Qt : Qnil;
576 DEFUN("numberp", Fnumberp, 1, 1, 0, /*
577 Return t if OBJECT is a number (floating point or integer).
581 #if defined(WITH_NUMBER_TYPES)
582 return NUMBERP(object) ? Qt : Qnil;
584 return INT_OR_FLOATP(object) ? Qt : Qnil;
588 DEFUN("number-or-marker-p", Fnumber_or_marker_p, 1, 1, 0, /*
589 Return t if OBJECT is a number or a marker.
593 return INT_OR_FLOATP(object) || MARKERP(object) ? Qt : Qnil;
596 DEFUN("number-char-or-marker-p", Fnumber_char_or_marker_p, 1, 1, 0, /*
597 Return t if OBJECT is a number, character or a marker.
601 return (INT_OR_FLOATP(object) || CHARP(object) || MARKERP(object))
606 DEFUN("floatp", Ffloatp, 1, 1, 0, /*
607 Return t if OBJECT is a floating point number.
611 return FLOATP(object) ? Qt : Qnil;
613 #endif /* HAVE_FPFLOAT */
615 DEFUN("type-of", Ftype_of, 1, 1, 0, /*
616 Return a symbol representing the type of OBJECT.
620 switch (XTYPE(object)) {
621 case Lisp_Type_Record:
622 if (XRECORD_LHEADER_IMPLEMENTATION(object)->
623 lrecord_type_index != lrecord_type_dynacat)
625 XRECORD_LHEADER_IMPLEMENTATION(object)->name);
626 else if (SYMBOLP(XDYNACAT_TYPE(object)))
627 return XDYNACAT_TYPE(object);
635 case Lisp_Type_Int_Even:
636 case Lisp_Type_Int_Odd:
642 /* Extract and set components of lists */
644 DEFUN("car", Fcar, 1, 1, 0, /*
645 Return the car of CONS. If CONS is nil, return nil.
647 The car of a list or a dotted pair is its first element.
648 Error if CONS is not nil and not a cons cell. See also `car-safe'.
658 cons = wrong_type_argument(Qlistp, cons);
662 DEFUN("car-safe", Fcar_safe, 1, 1, 0, /*
663 Return the car of OBJECT if it is a cons cell, or else nil.
665 The car of a list or a dotted pair is its first element.
669 return CONSP(object) ? XCAR(object) : Qnil;
672 DEFUN("cdr", Fcdr, 1, 1, 0, /*
673 Return the cdr of CONS. If CONS is nil, return nil.
675 The cdr of a list is the list without its first element. The cdr of a
676 dotted pair (A . B) is the second element, B.
678 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
688 cons = wrong_type_argument(Qlistp, cons);
692 DEFUN("cdr-safe", Fcdr_safe, 1, 1, 0, /*
693 Return the cdr of OBJECT if it is a cons cell, else nil.
695 The cdr of a list is the list without its first element. The cdr of a
696 dotted pair (A . B) is the second element, B.
700 return CONSP(object) ? XCDR(object) : Qnil;
703 DEFUN("setcar", Fsetcar, 2, 2, 0, /*
704 Set the car of CONS-CELL to be NEWCAR. Return NEWCAR.
706 The car of a list or a dotted pair is its first element.
710 if (!CONSP(cons_cell))
711 cons_cell = wrong_type_argument(Qconsp, cons_cell);
713 XCAR(cons_cell) = newcar;
717 DEFUN("setcdr", Fsetcdr, 2, 2, 0, /*
718 Set the cdr of CONS-CELL to be NEWCDR. Return NEWCDR.
720 The cdr of a list is the list without its first element. The cdr of a
721 dotted pair (A . B) is the second element, B.
725 if (!CONSP(cons_cell))
726 cons_cell = wrong_type_argument(Qconsp, cons_cell);
728 XCDR(cons_cell) = newcdr;
732 /* Find the function at the end of a chain of symbol function indirections.
734 If OBJECT is a symbol, find the end of its function chain and
735 return the value found there. If OBJECT is not a symbol, just
736 return it. If there is a cycle in the function chain, signal a
737 cyclic-function-indirection error.
739 This is like Findirect_function when VOID_FUNCTION_ERRORP is true.
740 When VOID_FUNCTION_ERRORP is false, no error is signaled if the end
741 of the chain ends up being Qunbound. */
742 Lisp_Object indirect_function(Lisp_Object object, int void_function_errorp)
744 #define FUNCTION_INDIRECTION_SUSPICION_LENGTH 16
745 Lisp_Object tortoise, hare;
748 for (hare = tortoise = object, count = 0;
749 SYMBOLP(hare); hare = XSYMBOL(hare)->function, count++) {
750 if (count < FUNCTION_INDIRECTION_SUSPICION_LENGTH)
754 tortoise = XSYMBOL(tortoise)->function;
755 if (EQ(hare, tortoise))
756 return Fsignal(Qcyclic_function_indirection,
760 if (void_function_errorp && UNBOUNDP(hare))
761 return signal_void_function_error(object);
766 DEFUN("indirect-function", Findirect_function, 1, 1, 0, /*
767 Return the function at the end of OBJECT's function chain.
768 If OBJECT is a symbol, follow all function indirections and return
769 the final function binding.
770 If OBJECT is not a symbol, just return it.
771 Signal a void-function error if the final symbol is unbound.
772 Signal a cyclic-function-indirection error if there is a loop in the
773 function chain of symbols.
777 return indirect_function(object, 1);
780 /* Extract and set vector and string elements */
782 DEFUN("aref", Faref, 2, 2, 0, /*
783 Return the element of ARRAY at index INDEX.
784 ARRAY may be a vector, bit vector, or string. INDEX starts at 0.
792 /* frob the position INDEX */
795 else if (CHARP(index_))
796 idx = XCHAR(index_); /* yuck! */
798 index_ = wrong_type_argument(Qinteger_or_char_p, index_);
802 /* frob the length of ARRAY */
804 alen = XVECTOR_LENGTH(array);
805 else if (BIT_VECTORP(array))
806 alen = bit_vector_length(XBIT_VECTOR(array));
807 else if (STRINGP(array))
808 alen = XSTRING_CHAR_LENGTH(array);
812 if (idx < 0 || idx >= alen)
816 return XVECTOR_DATA(array)[idx];
817 else if (BIT_VECTORP(array))
818 return make_int(bit_vector_bit(XBIT_VECTOR(array), idx));
819 else if (STRINGP(array))
820 return make_char(string_char(XSTRING(array), idx));
821 #ifdef LOSING_BYTECODE
822 else if (COMPILED_FUNCTIONP(array)) {
823 /* Weird, gross compatibility kludge */
824 return Felt(array, index_);
828 check_losing_bytecode("aref", array);
829 array = wrong_type_argument(Qarrayp, array);
834 args_out_of_range(array, index_);
835 return Qnil; /* not reached */
838 DEFUN("aset", Faset, 3, 3, 0, /*
839 Store into the element of ARRAY at index INDEX the value NEWVAL.
840 ARRAY may be a vector, bit vector, or string. INDEX starts at 0.
842 (array, index_, newval))
848 /* frob the INDEX position */
851 else if (CHARP(index_))
852 idx = XCHAR(index_); /* yuck! */
854 index_ = wrong_type_argument(Qinteger_or_char_p, index_);
858 /* frob the length of ARRAY */
860 alen = XVECTOR_LENGTH(array);
861 else if (BIT_VECTORP(array))
862 alen = bit_vector_length(XBIT_VECTOR(array));
863 else if (STRINGP(array))
864 alen = XSTRING_CHAR_LENGTH(array);
868 if (idx < 0 || idx >= alen)
871 if (VECTORP(array)) {
872 XVECTOR_DATA(array)[idx] = newval;
873 } else if (BIT_VECTORP(array)) {
875 set_bit_vector_bit(XBIT_VECTOR(array), idx, !ZEROP(newval));
876 } else if (STRINGP(array)) {
877 CHECK_CHAR_COERCE_INT(newval);
878 set_string_char(XSTRING(array), idx, XCHAR(newval));
879 bump_string_modiff(array);
881 array = wrong_type_argument(Qarrayp, array);
888 args_out_of_range(array, index_);
889 return Qnil; /* not reached */
892 /**********************************************************************/
893 /* Arithmetic functions */
894 /**********************************************************************/
903 #ifndef WITH_NUMBER_TYPES
905 number_char_or_marker_to_int_or_double(Lisp_Object obj, int_or_double * p)
910 p->c.ival = XINT(obj);
912 p->c.ival = XCHAR(obj);
913 else if (MARKERP(obj))
914 p->c.ival = marker_position(obj);
916 else if (FLOATP(obj))
917 p->c.dval = XFLOAT_DATA(obj), p->int_p = 0;
920 obj = wrong_type_argument(Qnumber_char_or_marker_p, obj);
925 static double number_char_or_marker_to_double(Lisp_Object obj)
929 return (double)XINT(obj);
931 return (double)XCHAR(obj);
932 else if (MARKERP(obj))
933 return (double)marker_position(obj);
935 else if (FLOATP(obj))
936 return XFLOAT_DATA(obj);
939 obj = wrong_type_argument(Qnumber_char_or_marker_p, obj);
945 static EMACS_INT integer_char_or_marker_to_int(Lisp_Object obj)
952 else if (MARKERP(obj))
953 return marker_position(obj);
955 obj = wrong_type_argument(Qinteger_char_or_marker_p, obj);
961 /* Convert between a 32-bit value and a cons of two 16-bit values.
962 This is used to pass 32-bit integers to and from the user.
963 Use time_to_lisp() and lisp_to_time() for time values.
965 If you're thinking of using this to store a pointer into a Lisp Object
966 for internal purposes (such as when calling record_unwind_protect()),
967 try using make_opaque_ptr()/get_opaque_ptr() instead. */
968 Lisp_Object word_to_lisp(unsigned int item)
970 return Fcons(make_int(item >> 16), make_int(item & 0xffff));
973 unsigned int lisp_to_word(Lisp_Object item)
978 Lisp_Object top = Fcar(item);
979 Lisp_Object bot = Fcdr(item);
982 return (XINT(top) << 16) | (XINT(bot) & 0xffff);
986 DEFUN("number-to-string", Fnumber_to_string, 1, 1, 0, /*
987 Convert NUMBER to a string by printing it in decimal.
988 Uses a minus sign if negative.
989 NUMBER may be an integer or a floating point number.
993 char buffer[VALBITS];
995 #ifdef WITH_NUMBER_TYPES
996 CHECK_NUMBER(number);
998 CHECK_INT_OR_FLOAT(number);
1002 if (FLOATP(number)) {
1003 char pigbuf[350]; /* see comments in float_to_string */
1005 float_to_string(pigbuf, XFLOAT_DATA(number), sizeof(pigbuf));
1006 return build_string(pigbuf);
1008 #endif /* HAVE_FPFLOAT */
1009 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1010 if (BIGZP(number)) {
1011 char *str = bigz_to_string(XBIGZ_DATA(number), 10);
1012 Lisp_Object retval = build_string(str);
1016 #endif /* HAVE_MPZ */
1017 #if defined HAVE_MPQ && defined WITH_GMP
1018 if (BIGQP(number)) {
1019 char *str = (char *)bigq_to_string(XBIGQ_DATA(number), 10);
1020 Lisp_Object retval = build_string(str);
1024 #endif /* HAVE_MPQ */
1025 #if defined HAVE_MPF && defined WITH_GMP
1026 if (BIGFP(number)) {
1027 char *str = (char *)bigf_to_string(XBIGF_DATA(number), 10);
1028 Lisp_Object retval = build_string(str);
1032 #endif /* HAVE_MPF */
1033 #if defined HAVE_MPFR && defined WITH_MPFR
1034 if (BIGFRP(number)) {
1035 char *str = (char*)bigfr_to_string(XBIGFR_DATA(number), 10);
1036 Lisp_Object retval = build_string(str);
1040 #endif /* HAVE_MPFR */
1041 #if defined HAVE_PSEUG && defined WITH_PSEUG
1042 if (BIGGP(number)) {
1043 char *str = (char *)bigg_to_string(XBIGG_DATA(number), 10);
1044 Lisp_Object retval = build_string(str);
1048 #endif /* HAVE_PSEUG */
1049 #if defined HAVE_MPC && defined WITH_MPC || \
1050 defined HAVE_PSEUC && defined WITH_PSEUC
1051 if (BIGCP(number)) {
1052 char *str = (char *)bigc_to_string(XBIGC_DATA(number), 10);
1053 Lisp_Object retval = build_string(str);
1057 #endif /* HAVE_MPC */
1058 #if defined HAVE_QUATERN && defined WITH_QUATERN
1059 if (QUATERNP(number)) {
1060 char *str = (char*)quatern_to_string(XQUATERN_DATA(number), 10);
1061 Lisp_Object retval = build_string(str);
1065 #endif /* HAVE_QUATERN */
1066 if (INDEFP(number)) {
1067 char *str = (char *)indef_to_string(XINDEF_DATA(number));
1068 Lisp_Object retval = build_string(str);
1073 long_to_string(buffer, XINT(number), sizeof(buffer));
1074 return build_string(buffer);
1077 #if !defined HAVE_MPZ || !(defined WITH_GMP || defined WITH_MP)
1078 static int digit_to_number(int character, int base)
1081 int digit = ((character >= '0' && character <= '9') ? character - '0' :
1084 'z') ? character - 'a' + 10 : (character >= 'A'
1086 'Z') ? character - 'A' +
1089 return digit >= base ? -1 : digit;
1091 #endif /* HAVE_MPZ */
1093 DEFUN("string-to-number", Fstring_to_number, 1, 2, 0, /*
1094 Convert STRING to a number by parsing it as a number in base BASE.
1095 This parses both integers and floating point numbers.
1096 It ignores leading spaces and tabs.
1098 If BASE is nil or omitted, base 10 is used.
1099 BASE must be an integer between 2 and 16 (inclusive).
1100 Floating point numbers always use base 10.
1102 If STRING is a float, the variable `read-real-as' decides how to
1103 interpret that float.
1110 CHECK_STRING(string);
1117 check_int_range(b, 2, 16);
1120 p = (char *)XSTRING_DATA(string);
1122 /* Skip any whitespace at the front of the number. Some versions of
1123 atoi do this anyway, so we might as well make Emacs lisp consistent. */
1124 while (*p == ' ' || *p == '\t')
1127 #if defined HAVE_PSEUG && defined WITH_PSEUG
1128 if (isgaussian_string(p))
1129 return read_bigg_string(p);
1130 #endif /* HAVE_PSEUG */
1132 #if defined HAVE_MPC && defined WITH_MPC || \
1133 defined HAVE_PSEUC && defined WITH_PSEUC
1134 if (isbigc_string(p))
1135 return read_bigc_string(p);
1136 #endif /* HAVE_MPC */
1138 #if defined HAVE_MPFR && defined WITH_MPFR
1139 if (isfloat_string(p) && b == 10) {
1140 if (!(default_real_precision) || Vread_real_as != Qbigfr)
1141 return make_float(str_to_fpfloat((const char*)p));
1143 return read_bigfr_string(p);
1145 #elif defined HAVE_MPF && defined WITH_GMP
1146 if (isfloat_string(p) && b == 10) {
1147 if (!(default_real_precision) || Vread_real_as != Qbigf)
1148 return make_float(str_to_fpfloat((const char*)p));
1150 return read_bigf_string(p);
1152 #elif defined HAVE_FPFLOAT
1153 if (isfloat_string(p) && b == 10)
1154 return make_float(str_to_fpfloat(p));
1155 #endif /* HAVE_MPFR || HAVE_MPFR || HAVE_FPFLOAT */
1157 if (ase_resc_elm_pred_f && ase_resc_elm_f &&
1158 ase_resc_elm_pred_f(p))
1159 return ase_resc_elm_f(p);
1161 #if defined HAVE_QUATERN && defined WITH_QUATERN
1162 if (isquatern_string(p))
1163 return read_quatern_string(p);
1164 #endif /* HAVE_QUATERN */
1166 #if defined HAVE_MPQ && defined WITH_GMP
1167 if (strchr (p, '/') != NULL) {
1169 return read_bigq_string(p);
1171 /* do we even need fractions in different bases? */
1182 while ((*end >= '0' && *end <= '9') ||
1183 (b > 10 && *end >= 'a' && *end <= 'a' + b - 11) ||
1184 (b > 10 && *end >= 'A' && *end <= 'A' + b - 11))
1190 while ((*end >= '0' && *end <= '9') ||
1191 (b > 10 && *end >= 'a' &&
1192 *end <= 'a' + b - 11) ||
1193 (b > 10 && *end >= 'A' &&
1194 *end <= 'A' + b - 11))
1202 bigq_set_string(bq, (const char *) p, b);
1204 bigq_canonicalize(bq);
1206 result = make_bigq_bq(bq);
1212 #endif /* HAVE_MPQ */
1214 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1224 while ((*end >= '0' && *end <= '9') ||
1225 (b > 10 && *end >= 'a' && *end <= 'a' + b - 11) ||
1226 (b > 10 && *end >= 'A' && *end <= 'A' + b - 11))
1231 retval = make_int(0);
1235 bigz_set_string(bz, (const char *)p, b);
1236 retval = ent_mpz_downgrade_maybe(bz);
1243 #else /* !HAVE_MPZ */
1246 /* Use the system-provided functions for base 10. */
1247 #if SIZEOF_EMACS_INT == SIZEOF_INT
1248 return make_int(atoi(p));
1249 #elif SIZEOF_EMACS_INT == SIZEOF_LONG
1250 return make_int(atol(p));
1251 #elif SIZEOF_EMACS_INT == SIZEOF_LONG_LONG_INT
1252 return make_int(atoll(p));
1261 } else if (*p == '+')
1264 int digit = digit_to_number(*p++, b);
1269 return make_int(negative * v);
1271 #endif /* HAVE_MPZ */
1275 DEFUN("logand", Flogand, 0, MANY, 0, /*
1276 Return bitwise-and of all the arguments.
1277 Arguments may be integers, or markers or characters converted to integers.
1279 (int nargs, Lisp_Object * args))
1281 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1283 Lisp_Object result, other;
1284 ase_object_type_t nt1, nt2;
1287 return make_int(~0);
1290 if (!(INTEGERP(result) || CHARP(result) || MARKERP(result)))
1291 result = wrong_type_argument(Qintegerp, result);
1294 return make_int(ent_int(result));
1296 for (i = 1; i < nargs; i++) {
1298 if (!(INTEGERP(other) || CHARP(other) || MARKERP(other)))
1299 other = wrong_type_argument(Qintegerp, other);
1301 nt1 = ase_optable_index(result);
1302 nt2 = ase_optable_index(other);
1304 if (nt1 == INT_T && nt2 == INT_T) {
1305 result = make_int(ent_int(result) & ent_int(other));
1306 } else if (nt1 == INT_T && nt2 == BIGZ_T) {
1307 bigz_set_long(ent_scratch_bigz, ent_int(result));
1308 bigz_and(ent_scratch_bigz,
1311 result = ent_mpz_downgrade_maybe(ent_scratch_bigz);
1312 } else if (nt1 == BIGZ_T && nt2 == INT_T) {
1313 bigz_set_long(ent_scratch_bigz, ent_int(other));
1314 bigz_and(ent_scratch_bigz,
1317 result = ent_mpz_downgrade_maybe(ent_scratch_bigz);
1318 } else if (nt1 == BIGZ_T && nt2 == BIGZ_T) {
1319 bigz_and(ent_scratch_bigz,
1322 result = ent_mpz_downgrade_maybe(ent_scratch_bigz);
1327 #else /* !HAVE_MPZ */
1328 EMACS_INT bits = ~0;
1329 Lisp_Object *args_end = args + nargs;
1331 while (args < args_end)
1332 bits &= integer_char_or_marker_to_int(*args++);
1334 return make_int(bits);
1335 #endif /* HAVE_MPZ */
1338 DEFUN("logior", Flogior, 0, MANY, 0, /*
1339 Return bitwise-or of all the arguments.
1340 Arguments may be integers, or markers or characters converted to integers.
1342 (int nargs, Lisp_Object * args))
1344 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1346 Lisp_Object result, other;
1347 ase_object_type_t nt1, nt2;
1353 if (!(INTEGERP(result) || CHARP(result) || MARKERP(result)))
1354 result = wrong_type_argument(Qintegerp, result);
1357 return make_int(ent_int(result));
1359 for (i = 1; i < nargs; i++) {
1361 if (!(INTEGERP(other) || CHARP(other) || MARKERP(other)))
1362 other = wrong_type_argument(Qintegerp, other);
1364 nt1 = ase_optable_index(result);
1365 nt2 = ase_optable_index(other);
1367 if (nt1 == INT_T && nt2 == INT_T) {
1368 result = make_int(ent_int(result) | ent_int(other));
1369 } else if (nt1 == INT_T && nt2 == BIGZ_T) {
1370 bigz_set_long(ent_scratch_bigz, ent_int(result));
1371 bigz_ior(ent_scratch_bigz,
1374 result = ent_mpz_downgrade_maybe(ent_scratch_bigz);
1375 } else if (nt1 == BIGZ_T && nt2 == INT_T) {
1376 bigz_set_long(ent_scratch_bigz, ent_int(other));
1377 bigz_ior(ent_scratch_bigz,
1380 result = ent_mpz_downgrade_maybe(ent_scratch_bigz);
1381 } else if (nt1 == BIGZ_T && nt2 == BIGZ_T) {
1382 bigz_ior(ent_scratch_bigz,
1385 result = ent_mpz_downgrade_maybe(ent_scratch_bigz);
1390 #else /* !HAVE_MPZ */
1393 Lisp_Object *args_end = args + nargs;
1395 while (args < args_end)
1396 bits |= integer_char_or_marker_to_int(*args++);
1398 return make_int(bits);
1399 #endif /* HAVE_MPZ */
1402 DEFUN("logxor", Flogxor, 0, MANY, 0, /*
1403 Return bitwise-exclusive-or of all the arguments.
1404 Arguments may be integers, or markers or characters converted to integers.
1406 (int nargs, Lisp_Object * args))
1408 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1410 Lisp_Object result, other;
1411 ase_object_type_t nt1, nt2;
1417 if (!(INTEGERP(result) || CHARP(result) || MARKERP(result)))
1418 result = wrong_type_argument(Qintegerp, result);
1421 return make_int(ent_int(result));
1423 for (i = 1; i < nargs; i++) {
1425 if (!(INTEGERP(other) || CHARP(other) || MARKERP(other)))
1426 other = wrong_type_argument(Qintegerp, other);
1428 nt1 = ase_optable_index(result);
1429 nt2 = ase_optable_index(other);
1431 if (nt1 == INT_T && nt2 == INT_T) {
1432 result = make_int(ent_int(result) ^ ent_int(other));
1433 } else if (nt1 == INT_T && nt2 == BIGZ_T) {
1434 bigz_set_long(ent_scratch_bigz, ent_int(result));
1435 bigz_xor(ent_scratch_bigz,
1438 result = ent_mpz_downgrade_maybe(ent_scratch_bigz);
1439 } else if (nt1 == BIGZ_T && nt2 == INT_T) {
1440 bigz_set_long(ent_scratch_bigz, ent_int(other));
1441 bigz_xor(ent_scratch_bigz,
1444 result = ent_mpz_downgrade_maybe(ent_scratch_bigz);
1445 } else if (nt1 == BIGZ_T && nt2 == BIGZ_T) {
1446 bigz_xor(ent_scratch_bigz,
1449 result = ent_mpz_downgrade_maybe(ent_scratch_bigz);
1454 #else /* !HAVE_MPZ */
1457 Lisp_Object *args_end = args + nargs;
1459 while (args < args_end)
1460 bits ^= integer_char_or_marker_to_int(*args++);
1462 return make_int(bits);
1463 #endif /* HAVE_MPZ */
1466 DEFUN("lognot", Flognot, 1, 1, 0, /*
1467 Return the bitwise complement of NUMBER.
1468 NUMBER may be an integer, marker or character converted to integer.
1472 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1473 if (BIGZP(number)) {
1479 bigz_not(bz, XBIGZ_DATA(number));
1480 result = make_bigz_bz(bz);
1485 return make_int(~integer_char_or_marker_to_int(number));
1487 #else /* HAVE_MPZ */
1488 return make_int(~integer_char_or_marker_to_int(number));
1489 #endif /* HAVE_MPZ */
1492 /* Note, ANSI *requires* the presence of the fmod() library routine.
1493 If your system doesn't have it, complain to your vendor, because
1497 double fmod(double f1, double f2)
1501 return f1 - f2 * floor(f1 / f2);
1503 #endif /* ! HAVE_FMOD */
1505 DEFUN("ash", Fash, 2, 2, 0, /*
1506 Return VALUE with its bits shifted left by COUNT.
1507 If COUNT is negative, shifting is actually to the right.
1508 In this case, the sign bit is duplicated.
1512 CHECK_INT_COERCE_CHAR(value);
1513 CONCHECK_INT(count);
1515 return make_int(XINT(count) > 0 ?
1516 XINT(value) << XINT(count) :
1517 XINT(value) >> -XINT(count));
1520 DEFUN("lsh", Flsh, 2, 2, 0, /*
1521 Return VALUE with its bits shifted left by COUNT.
1522 If COUNT is negative, shifting is actually to the right.
1523 In this case, zeros are shifted in on the left.
1527 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1531 value = Fcoerce_number(value, Qinteger, Qnil);
1532 CONCHECK_INT(count);
1534 switch (ase_optable_index(value)) {
1536 if (XREALINT(count) <= 0)
1537 return make_int(XREALINT(value) >> -XREALINT(count));
1538 /* Use bignums to avoid overflow */
1539 bigz_set_long(ent_scratch_bigz, XREALINT(value));
1540 bigz_lshift(ent_scratch_bigz,
1541 ent_scratch_bigz, XREALINT(count));
1543 result = ent_mpz_downgrade_maybe(ent_scratch_bigz);
1546 if (XREALINT(count) <= 0) {
1547 bigz_rshift(ent_scratch_bigz,
1551 bigz_lshift(ent_scratch_bigz,
1555 result = ent_mpz_downgrade_maybe(ent_scratch_bigz);
1558 if (COMPARABLE_INDEF_P(value))
1560 else if (COMPARABLE_INDEF_P(count) &&
1561 XINDEF_DATA(count) == POS_INFINITY)
1562 result = make_indef(POS_INFINITY);
1563 else if (COMPARABLE_INDEF_P(count) &&
1564 XINDEF_DATA(count) == NEG_INFINITY)
1573 #else /* HAVE_MPZ */
1574 CHECK_INT_COERCE_CHAR(value);
1575 CONCHECK_INT(count);
1577 return make_int(XINT(count) > 0 ?
1578 XUINT(value) << XINT(count) :
1579 XUINT(value) >> -XINT(count));
1580 #endif /* HAVE_MPZ */
1583 /* Number theoretic functions */
1585 #if defined WITH_GMP && defined HAVE_MPZ
1587 /* why do we put this cruft here, actually? Is not it better to have a separate
1588 * number-fns.c or the like?
1591 DEFUN("primep", Fprimep, 1, 2, 0, /*
1592 Return `nil' if NUMBER is known to be composite, return `t' if
1593 NUMBER is definitely prime and return 'probably-prime if
1594 NUMBER seems to be prime but it is not certain.
1596 If optional argument CERTAINTY-THRESHOLD is non-nil, it should be a
1597 natural number to indicate how many probabilistic primality tests must
1598 be passed in order to have certainty about the primality of NUMBER.
1601 (number, certainty_threshold))
1603 Lisp_Object bznumber;
1609 bznumber = Fcoerce_number(number, Qbigz, Qnil);
1610 if (NILP(certainty_threshold))
1611 result = mpz_probab_prime_p(XBIGZ_DATA(bznumber), 8);
1612 else if (NATNUMP(certainty_threshold))
1613 result = mpz_probab_prime_p(XBIGZ_DATA(bznumber),
1614 XINT(certainty_threshold));
1616 result = wrong_type_argument(Qnatnump, certainty_threshold);
1620 else if (result == 1)
1621 return intern("probably-prime");
1622 else if (result == 2)
1625 return intern("unknown-test-result");
1628 DEFUN("next-prime", Fnext_prime, 1, 1, 0, /*
1629 Return the next prime number greater than NUMBER.
1633 Lisp_Object bznumber;
1635 if (INDEFP(number)) {
1639 bznumber = Fcoerce_number(number, Qbigz, Qnil);
1640 mpz_nextprime(ent_scratch_bigz, XBIGZ_DATA(bznumber));
1641 return ent_mpz_downgrade_maybe(ent_scratch_bigz);
1645 DEFUN("factorial", Ffactorial, 1, 1, 0, /*
1646 Return the factorial of NUMBER.
1653 if (INDEFP(number) &&
1654 XINDEF_DATA(number) == POS_INFINITY)
1657 if (!INTP(number)) {
1658 number = wrong_type_argument(Qintegerp, number);
1661 if (!NATNUMP(number)) {
1662 number = wrong_type_argument(Qnatnump, number);
1668 mpz_fac_ui(bz, XUINT(number));
1669 result = make_bigz_bz(bz);
1675 DEFUN("binomial-coefficient", Fbinomial_coefficient, 2, 2, 0, /*
1676 Return the binomial coefficient, N over K.
1687 if (NILP(Fnonnegativep(k)))
1688 return wrong_type_argument(Qnonnegativep, k);
1692 kui = bigz_to_ulong(XBIGZ_DATA(k));
1694 return wrong_type_argument(Qintegerp, k);
1696 n = Fcoerce_number(n, Qbigz, Qnil);
1699 mpz_bin_ui(bz, XBIGZ_DATA(n), kui);
1700 result = make_bigz_bz(bz);
1706 DEFUN("remove-factor", Fremove_factor, 2, 2, 0, /*
1707 Remove all occurences of FACTOR in NUMBER and return a cons cell
1708 with NUMBER divided by a maximal power of FACTOR in the car and
1709 the exponent in the cdr.
1710 FACTOR must be non-negative and greater than 1.
1714 Lisp_Object bznumber, bzfactor;
1717 unsigned long occur;
1719 if (INDEFP(factor) && INDEFP(number)) {
1720 if (XINDEF_DATA(factor) == POS_INFINITY)
1721 return Fcons(factor, factor);
1723 return wrong_type_argument(Qnonnegativep, factor);
1725 if (INDEFP(factor)) {
1726 if (XINDEF_DATA(factor) == POS_INFINITY)
1727 return Fcons(number, Qzero);
1729 return wrong_type_argument(Qnonnegativep, factor);
1731 if (INDEFP(number)) {
1732 if (INFINITYP(number))
1733 return Fcons(number, make_indef(POS_INFINITY));
1735 return wrong_type_argument(Qnumberp, number);
1740 bznumber = Fcoerce_number(number, Qbigz, Qnil);
1741 bzfactor = Fcoerce_number(factor, Qbigz, Qnil);
1743 bigz_set_long(bz, 1L);
1744 if (bigz_eql(XBIGZ_DATA(bzfactor), bz)) {
1745 /* factor is one, which is always in a prime decomposition */
1747 return Fcons(bznumber, make_indef(POS_INFINITY));
1749 bigz_set_long(bz, -1L);
1750 if (bigz_eql(XBIGZ_DATA(bzfactor), bz)) {
1751 /* factor is -1, which is always in a prime decomposition
1752 * (it is a unit), but as such it occurs only pairwise, that's
1753 * why we return 0 as exponent here
1756 return Fcons(bznumber, Qzero);
1758 bigz_set_long(bz, 0L);
1759 if (bigz_eql(XBIGZ_DATA(bzfactor), bz)) {
1760 /* factor is zero, which is never in a prime decomposition */
1762 return Fcons(bznumber, Qzero);
1764 if (bigz_lt(XBIGZ_DATA(bzfactor), bz)) {
1765 /* factor is negative, which is bad if number is positive */
1766 bigz_neg(XBIGZ_DATA(bzfactor), XBIGZ_DATA(bzfactor));
1767 occur = mpz_remove(bz, XBIGZ_DATA(bznumber),
1768 XBIGZ_DATA(bzfactor));
1769 /* negate the result, iff the exponent is odd */
1770 if ((occur % 2) != 0)
1772 result = make_bigz_bz(bz);
1774 occur = mpz_remove(bz,
1775 XBIGZ_DATA(bznumber),
1776 XBIGZ_DATA(bzfactor));
1777 result = make_bigz_bz(bz);
1781 return Fcons(result, make_integer((signed long)occur));
1784 DEFUN("fibonacci", Ffibonacci, 1, 1, 0, /*
1785 Return the NUMBERth Fibonacci number.
1786 To compute both, the NUMBERth and (NUMBER-1)th Fibonacci
1787 number use `fibonacci2' instead.
1795 CHECK_INTEGER(number);
1797 if (NILP(Fnonnegativep(number)))
1798 return wrong_type_argument(Qnonnegativep, number);
1799 else if (INTP(number))
1801 else if (BIGZP(number))
1802 n = bigz_to_ulong(XBIGZ_DATA(number));
1804 return wrong_type_argument(Qintegerp, number);
1808 result = make_bigz_bz(bz);
1814 DEFUN("fibonacci2", Ffibonacci2, 1, 1, 0, /*
1815 Return a cons with the NUMBERth and (NUMBER-1)th Fibonacci number.
1816 To compute a series of Fibonacci numbers starting at index
1817 NUMBER, use this function and recursively compute the rest.
1825 CHECK_INTEGER(number);
1827 if (NILP(Fnonnegativep(number)))
1828 return wrong_type_argument(Qnonnegativep, number);
1829 else if (INTP(number))
1831 else if (BIGZP(number))
1832 n = bigz_to_ulong(XBIGZ_DATA(number));
1834 return wrong_type_argument(Qintegerp, number);
1838 mpz_fib2_ui(bzn, bznsub1, n);
1839 result = Fcons(make_bigz_bz(bzn),
1840 make_bigz_bz(bznsub1));
1847 DEFUN("lucas", Flucas, 1, 1, 0, /*
1848 Return the NUMBERth Lucas number.
1849 To compute both, the NUMBERth and (NUMBER-1)th Lucas
1850 number use `lucas2' instead.
1858 CHECK_INTEGER(number);
1860 if (NILP(Fnonnegativep(number)))
1861 return wrong_type_argument(Qnonnegativep, number);
1862 else if (INTP(number))
1864 else if (BIGZP(number))
1865 n = bigz_to_ulong(XBIGZ_DATA(number));
1867 return wrong_type_argument(Qintegerp, number);
1870 mpz_lucnum_ui(bz, n);
1871 result = make_bigz_bz(bz);
1877 DEFUN("lucas2", Flucas2, 1, 1, 0, /*
1878 Return a cons with the NUMBERth and (NUMBER-1)th Lucas number.
1879 To compute a series of Lucas numbers starting at index
1880 NUMBER, use this function and recursively compute the rest.
1888 CHECK_INTEGER(number);
1890 if (NILP(Fnonnegativep(number)))
1891 return wrong_type_argument(Qnonnegativep, number);
1892 else if (INTP(number))
1894 else if (BIGZP(number))
1895 n = bigz_to_ulong(XBIGZ_DATA(number));
1897 return wrong_type_argument(Qintegerp, number);
1901 mpz_lucnum2_ui(bzn, bznsub1, n);
1902 result = Fcons(make_bigz_bz(bzn),
1903 make_bigz_bz(bznsub1));
1910 DEFUN("divisiblep", Fdivisiblep, 2, 2, 0, /*
1911 Return t if NUMBER is divisible by D, nil otherwise.
1915 CHECK_INTEGER(number);
1918 number = Fcoerce_number(number, Qbigz, Qnil);
1920 return mpz_divisible_ui_p(XBIGZ_DATA(number), XINT(d))
1923 return mpz_divisible_p(XBIGZ_DATA(number), XBIGZ_DATA(d))
1926 return wrong_type_argument(Qintegerp, d);
1929 DEFUN("congruentp", Fcongruentp, 3, 3, 0, /*
1930 Return t if NUMBER is congruent to C modulo M, nil otherwise.
1934 CHECK_INTEGER(number);
1938 number = Fcoerce_number(number, Qbigz, Qnil);
1939 if (INTP(c) && INTP(m))
1940 return mpz_congruent_ui_p(XBIGZ_DATA(number), XINT(c), XINT(m))
1943 c = Fcoerce_number(c, Qbigz, Qnil);
1944 m = Fcoerce_number(m, Qbigz, Qnil);
1945 return mpz_congruent_p(XBIGZ_DATA(number),
1946 XBIGZ_DATA(c), XBIGZ_DATA(m))
1951 DEFUN("perfect-power-p", Fperfect_power_p, 1, 1, 0, /*
1952 Return t if NUMBER is a perfect power, nil otherwise.
1953 An integer NUMBER is said to be a perfect power if there
1954 exist integers, a and b, such that a^b = NUMBER.
1958 CHECK_INTEGER(number);
1960 number = Fcoerce_number(number, Qbigz, Qnil);
1962 return mpz_perfect_power_p(XBIGZ_DATA(number)) ? Qt : Qnil;
1965 DEFUN("perfect-square-p", Fperfect_square_p, 1, 1, 0, /*
1966 Return t if NUMBER is a perfect square, nil otherwise.
1967 An integer NUMBER is said to be a perfect square if there
1968 exists an integer b such that b^2 = NUMBER.
1972 CHECK_INTEGER(number);
1974 number = Fcoerce_number(number, Qbigz, Qnil);
1976 return mpz_perfect_square_p(XBIGZ_DATA(number)) ? Qt : Qnil;
1979 DEFUN("integral-sqrt", Fintegral_sqrt, 1, 1, 0, /*
1980 Return a cons with the integral square root of NUMBER
1981 in the car and the remainder in the cdr.
1982 An integral square root is a number b and a remainder c
1983 such that b*b + c = NUMBER.
1990 CHECK_INTEGER(number);
1992 number = Fcoerce_number(number, Qbigz, Qnil);
1996 mpz_sqrtrem(bzsqrt, bzrem, XBIGZ_DATA(number));
1998 result = Fcons(make_bigz_bz(bzsqrt), make_bigz_bz(bzrem));
2005 #endif /* WITH_GMP && HAVE_MPZ */
2007 DEFUN("zero-divisor-p", Fzero_divisor_p, 1, 1, 0, /*
2008 Return t if NUMBER is a zero-divisor, nil otherwise.
2009 That is, if there exists another non-zero number B, such that
2016 CHECK_NUMBER(number);
2018 switch (ase_optable_index(number)) {
2025 #if defined WITH_ECM && defined HAVE_ECM && \
2026 defined HAVE_MPZ && defined WITH_GMP
2027 DEFUN("factorise", Ffactorise, 1, 3, 0, /*
2028 Return the factorisation of NUMBER.
2029 If optional arument B1 is non-nil, it should be a float used as
2031 Second optional argument method can be 'ecm, 'p-1 'p+1.
2033 (number, b1, method))
2041 Lisp_Object result = Qnil;
2045 bzn = Fcoerce_number(number, Qbigz, Qnil);
2048 bigz_init(bznumber);
2049 bigz_set(bznumber, XBIGZ_DATA(bzn));
2054 sb1 = extract_float(b1);
2058 } else if (method == intern("p-1")) {
2059 p->method = ECM_PM1;
2060 } else if (method == intern("p+1")) {
2061 p->method = ECM_PP1;
2063 p->method = ECM_ECM;
2067 while (status > 0) {
2068 status = ecm_factor(bz, bznumber, sb1, p);
2070 factor_l = bigz_to_long(bz);
2071 if (factor_l == 1 || factor_l == -1)
2073 if (status > 0 && factor_l != 0) {
2074 expt = mpz_remove(bznumber, bznumber, bz);
2075 result = Fcons(Fcons(make_bigz_bz(bz),
2082 bigz_fini(bznumber);
2087 #endif /* WITH_ECM && HAVE_ECM */
2089 #if defined(WITH_GMP) && (defined(HAVE_MPZ) || defined(HAVE_MPQ))
2090 DEFUN("gcd", Fgcd, 0, MANY, 0, /*
2091 Return the greatest common divisor of the arguments.
2093 (int nargs, Lisp_Object *args))
2099 else if (nargs == 1)
2111 switch (ase_optable_index(bzn)) {
2113 bzn = Fcoerce_number(bzn, Qbigz, Qnil);
2114 bigz_set(bz, XBIGZ_DATA(bzn));
2115 bigz_set_long(bzden, 1L);
2118 bigz_set(bz, XBIGZ_DATA(bzn));
2119 bigz_set_long(bzden, 1L);
2122 bigz_set(bz, XBIGQ_NUMERATOR(bzn));
2123 bigz_set(bzden, XBIGQ_DENOMINATOR(bzn));
2126 /* no gcd defined for the rest */
2135 for (i = 1; i < nargs; i++) {
2138 switch (ase_optable_index(bzn)) {
2140 bzn = Fcoerce_number(bzn, Qbigz, Qnil);
2141 bigz_set(bznum, XBIGZ_DATA(bzn));
2144 bigz_set(bznum, XBIGZ_DATA(bzn));
2147 bigz_mul(bzden, bzden, XBIGQ_DENOMINATOR(bzn));
2148 bigz_set(bznum, XBIGQ_NUMERATOR(bzn));
2151 /* no gcd defined for the rest */
2160 bigz_gcd(bz, bz, bznum);
2162 if (bigz_fits_long_p(bzden) &&
2163 bigz_to_long(bzden) == 1L) {
2164 bzn = make_bigz_bz(bz);
2166 bzn = make_bigq_bz(bz, bzden);
2177 DEFUN("xgcd", Fxgcd, 0, MANY, 0, /*
2178 Return the extended gcd of the arguments.
2179 The result is a list of integers, where the car is the actual gcd
2180 and the cdr consists of coefficients, s1, ..., sn, such that
2181 s1*arg1 + s2*arg2 + ... + sn*argn = gcd.
2183 (int nargs, Lisp_Object *args))
2188 return list1(Qzero);
2189 else if (nargs == 1)
2190 return list2(args[0], make_int(1L));
2198 Lisp_Object *qargs = alloca_array(Lisp_Object, nargs+1);
2206 switch (ase_optable_index(bzn)) {
2208 bzn = Fcoerce_number(bzn, Qbigz, Qnil);
2209 bigz_set(bz, XBIGZ_DATA(bzn));
2210 bigz_set_long(bzden, 1L);
2213 bigz_set(bz, XBIGZ_DATA(bzn));
2214 bigz_set_long(bzden, 1L);
2217 bigz_set(bz, XBIGQ_NUMERATOR(bzn));
2218 bigz_set(bzden, XBIGQ_DENOMINATOR(bzn));
2221 /* no gcd defined for the rest */
2228 return list1(Qzero);
2232 qargs[1] = make_bigz(1L);
2233 for (i = 1; i < nargs; i++) {
2236 switch (ase_optable_index(bzn)) {
2238 bzn = Fcoerce_number(bzn, Qbigz, Qnil);
2239 bigz_set(bznum, XBIGZ_DATA(bzn));
2242 bigz_set(bznum, XBIGZ_DATA(bzn));
2244 /* multiply across fractions */
2246 bigz_set(bznum, XBIGQ_NUMERATOR(bzn));
2247 bigz_mul(bznum, bznum, bzden);
2248 bigz_mul(bzden, bzden, XBIGQ_DENOMINATOR(bzn));
2249 bigz_mul(bz, bz, XBIGQ_DENOMINATOR(bzn));
2252 /* no gcd defined for the rest */
2259 return list1(Qzero);
2263 mpz_gcdext(bz, bs, bt, bz, bznum);
2264 for (j = i; j > 0; j--) {
2265 bigz_mul(XBIGZ_DATA(qargs[j]),
2266 XBIGZ_DATA(qargs[j]),
2269 qargs[i+1] = make_bigz_bz(bt);
2271 if (bigz_fits_long_p(bzden) &&
2272 bigz_to_long(bzden) == 1L) {
2273 qargs[0] = make_bigz_bz(bz);
2275 qargs[0] = make_bigq_bz(bz, bzden);
2282 return Flist(nargs+1, qargs);
2288 DEFUN("lcm", Flcm, 0, MANY, 0, /*
2289 Return the least common multiple of the arguments.
2291 (int nargs, Lisp_Object *args))
2297 else if (nargs == 1)
2309 switch (ase_optable_index(bzn)) {
2311 bzn = Fcoerce_number(bzn, Qbigz, Qnil);
2312 bigz_set(bz, XBIGZ_DATA(bzn));
2313 bigz_set_long(bzden, 1L);
2316 bigz_set(bz, XBIGZ_DATA(bzn));
2317 bigz_set_long(bzden, 1L);
2320 bigz_set(bz, XBIGQ_NUMERATOR(bzn));
2321 bigz_set(bzden, XBIGQ_DENOMINATOR(bzn));
2324 /* no lcm defined for the rest */
2333 for (i = 1; i < nargs; i++) {
2336 switch (ase_optable_index(bzn)) {
2338 bzn = Fcoerce_number(bzn, Qbigz, Qnil);
2339 bigz_set(bznum, XBIGZ_DATA(bzn));
2342 bigz_set(bznum, XBIGZ_DATA(bzn));
2344 /* multiply across fractions */
2346 bigz_set(bznum, XBIGQ_NUMERATOR(bzn));
2347 bigz_mul(bznum, bznum, bzden);
2348 bigz_mul(bzden, bzden, XBIGQ_DENOMINATOR(bzn));
2349 bigz_mul(bz, bz, XBIGQ_DENOMINATOR(bzn));
2352 /* no gcd defined for the rest */
2360 bigz_lcm(bz, bz, bznum);
2362 if (bigz_fits_long_p(bzden) &&
2363 bigz_to_long(bzden) == 1L) {
2364 bzn = make_bigz_bz(bz);
2366 bzn = make_bigq_bz(bz, bzden);
2376 #endif /* WITH_GMP && (HAVE_MPZ || HAVE_MPQ) */
2379 /************************************************************************/
2381 /************************************************************************/
2383 /* A weak list is like a normal list except that elements automatically
2384 disappear when no longer in use, i.e. when no longer GC-protected.
2385 The basic idea is that we don't mark the elements during GC, but
2386 wait for them to be marked elsewhere. If they're not marked, we
2387 remove them. This is analogous to weak hash tables; see the explanation
2388 there for more info. */
2390 static Lisp_Object Vall_weak_lists; /* Gemarke es nicht!!! */
2392 static Lisp_Object encode_weak_list_type(enum weak_list_type type);
2394 static Lisp_Object mark_weak_list(Lisp_Object obj)
2396 return Qnil; /* nichts ist gemarkt */
2397 /* avoid some warning */
2398 return (obj == Qnil);
2402 print_weak_list(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
2405 error("printing unreadable object #<weak-list>");
2407 write_c_string("#<weak-list ", printcharfun);
2408 print_internal(encode_weak_list_type(XWEAK_LIST(obj)->type),
2410 write_c_string(" ", printcharfun);
2411 print_internal(XWEAK_LIST(obj)->list, printcharfun, escapeflag);
2412 write_c_string(">", printcharfun);
2415 static int weak_list_equal(Lisp_Object obj1, Lisp_Object obj2, int depth)
2417 struct weak_list *w1 = XWEAK_LIST(obj1);
2418 struct weak_list *w2 = XWEAK_LIST(obj2);
2420 return ((w1->type == w2->type) &&
2421 internal_equal(w1->list, w2->list, depth + 1));
2424 static unsigned long weak_list_hash(Lisp_Object obj, int depth)
2426 struct weak_list *w = XWEAK_LIST(obj);
2428 return HASH2((unsigned long)w->type, internal_hash(w->list, depth + 1));
2431 Lisp_Object make_weak_list(enum weak_list_type type)
2434 struct weak_list *wl =
2435 alloc_lcrecord_type(struct weak_list, &lrecord_weak_list);
2439 XSETWEAK_LIST(result, wl);
2440 wl->next_weak = Vall_weak_lists;
2441 Vall_weak_lists = result;
2445 static const struct lrecord_description weak_list_description[] = {
2446 {XD_LISP_OBJECT, offsetof(struct weak_list, list)},
2447 {XD_LO_LINK, offsetof(struct weak_list, next_weak)},
2451 DEFINE_LRECORD_IMPLEMENTATION("weak-list", weak_list,
2452 mark_weak_list, print_weak_list,
2453 0, weak_list_equal, weak_list_hash,
2454 weak_list_description, struct weak_list);
2456 -- we do not mark the list elements (either the elements themselves
2457 or the cons cells that hold them) in the normal marking phase.
2458 -- at the end of marking, we go through all weak lists that are
2459 marked, and mark the cons cells that hold all marked
2460 objects, and possibly parts of the objects themselves.
2461 (See alloc.c, "after-mark".)
2462 -- after that, we prune away all the cons cells that are not marked.
2464 WARNING WARNING WARNING WARNING WARNING:
2466 The code in the following two functions is *unbelievably* tricky.
2467 Don't mess with it. You'll be sorry.
2469 Linked lists just majorly suck, d'ya know?
2472 int finish_marking_weak_lists(void)
2477 for (rest = Vall_weak_lists;
2478 !NILP(rest); rest = XWEAK_LIST(rest)->next_weak) {
2480 enum weak_list_type type = XWEAK_LIST(rest)->type;
2482 if (!marked_p(rest))
2483 /* The weak list is probably garbage. Ignore it. */
2486 for (rest2 = XWEAK_LIST(rest)->list;
2487 /* We need to be trickier since we're inside of GC;
2488 use CONSP instead of !NILP in case of user-visible
2490 CONSP(rest2); rest2 = XCDR(rest2)) {
2492 /* If the element is "marked" (meaning depends on the type
2493 of weak list), we need to mark the cons containing the
2494 element, and maybe the element itself (if only some part
2495 was already marked). */
2496 int need_to_mark_cons = 0;
2497 int need_to_mark_elem = 0;
2499 /* If a cons is already marked, then its car is already marked
2500 (either because of an external pointer or because of
2501 a previous call to this function), and likewise for all
2502 the rest of the elements in the list, so we can stop now. */
2503 if (marked_p(rest2))
2509 case WEAK_LIST_SIMPLE:
2511 need_to_mark_cons = 1;
2514 case WEAK_LIST_ASSOC:
2516 /* just leave bogus elements there */
2517 need_to_mark_cons = 1;
2518 need_to_mark_elem = 1;
2519 } else if (marked_p(XCAR(elem)) &&
2520 marked_p(XCDR(elem))) {
2521 need_to_mark_cons = 1;
2522 /* We still need to mark elem, because it's
2523 probably not marked. */
2524 need_to_mark_elem = 1;
2528 case WEAK_LIST_KEY_ASSOC:
2530 /* just leave bogus elements there */
2531 need_to_mark_cons = 1;
2532 need_to_mark_elem = 1;
2533 } else if (marked_p(XCAR(elem))) {
2534 need_to_mark_cons = 1;
2535 /* We still need to mark elem and XCDR (elem);
2536 marking elem does both */
2537 need_to_mark_elem = 1;
2541 case WEAK_LIST_VALUE_ASSOC:
2543 /* just leave bogus elements there */
2544 need_to_mark_cons = 1;
2545 need_to_mark_elem = 1;
2546 } else if (marked_p(XCDR(elem))) {
2547 need_to_mark_cons = 1;
2548 /* We still need to mark elem and XCAR (elem);
2549 marking elem does both */
2550 need_to_mark_elem = 1;
2554 case WEAK_LIST_FULL_ASSOC:
2556 /* just leave bogus elements there */
2557 need_to_mark_cons = 1;
2558 need_to_mark_elem = 1;
2559 } else if (marked_p(XCAR(elem)) ||
2560 marked_p(XCDR(elem))) {
2561 need_to_mark_cons = 1;
2562 /* We still need to mark elem and XCAR (elem);
2563 marking elem does both */
2564 need_to_mark_elem = 1;
2572 if (need_to_mark_elem && !marked_p(elem)) {
2577 /* We also need to mark the cons that holds the elem or
2578 assoc-pair. We do *not* want to call (mark_object) here
2579 because that will mark the entire list; we just want to
2580 mark the cons itself.
2582 if (need_to_mark_cons) {
2583 Lisp_Cons *c = XCONS(rest2);
2584 if (!CONS_MARKED_P(c)) {
2591 /* In case of imperfect list, need to mark the final cons
2592 because we're not removing it */
2593 if (!NILP(rest2) && !marked_p(rest2)) {
2602 void prune_weak_lists(void)
2604 Lisp_Object rest, prev = Qnil;
2606 for (rest = Vall_weak_lists;
2607 !NILP(rest); rest = XWEAK_LIST(rest)->next_weak) {
2608 if (!(marked_p(rest))) {
2609 /* This weak list itself is garbage. Remove it from the list. */
2611 Vall_weak_lists = XWEAK_LIST(rest)->next_weak;
2613 XWEAK_LIST(prev)->next_weak =
2614 XWEAK_LIST(rest)->next_weak;
2616 Lisp_Object rest2, prev2 = Qnil;
2617 Lisp_Object tortoise;
2618 int go_tortoise = 0;
2620 for (rest2 = XWEAK_LIST(rest)->list, tortoise = rest2;
2621 /* We need to be trickier since we're inside of GC;
2622 use CONSP instead of !NILP in case of user-visible
2625 /* It suffices to check the cons for marking,
2626 regardless of the type of weak list:
2628 -- if the cons is pointed to somewhere else,
2629 then it should stay around and will be marked.
2630 -- otherwise, if it should stay around, it will
2631 have been marked in finish_marking_weak_lists().
2632 -- otherwise, it's not marked and should disappear.
2634 if (!marked_p(rest2)) {
2637 XWEAK_LIST(rest)->list =
2640 XCDR(prev2) = XCDR(rest2);
2641 rest2 = XCDR(rest2);
2642 /* Ouch. Circularity checking is even trickier
2643 than I thought. When we cut out a link
2644 like this, we can't advance the turtle or
2645 it'll catch up to us. Imagine that we're
2646 standing on floor tiles and moving forward --
2647 what we just did here is as if the floor
2648 tile under us just disappeared and all the
2649 ones ahead of us slid one tile towards us.
2650 In other words, we didn't move at all;
2651 if the tortoise was one step behind us
2652 previously, it still is, and therefore
2653 it must not move. */
2657 /* Implementing circularity checking is trickier here
2658 than in other places because we have to guarantee
2659 that we've processed all elements before exiting
2660 due to a circularity. (In most places, an error
2661 is issued upon encountering a circularity, so it
2662 doesn't really matter if all elements are processed.)
2663 The idea is that we process along with the hare
2664 rather than the tortoise. If at any point in
2665 our forward process we encounter the tortoise,
2666 we must have already visited the spot, so we exit.
2667 (If we process with the tortoise, we can fail to
2668 process cases where a cons points to itself, or
2669 where cons A points to cons B, which points to
2672 rest2 = XCDR(rest2);
2674 tortoise = XCDR(tortoise);
2675 go_tortoise = !go_tortoise;
2676 if (EQ(rest2, tortoise))
2686 static enum weak_list_type decode_weak_list_type(Lisp_Object symbol)
2688 CHECK_SYMBOL(symbol);
2689 if (EQ(symbol, Qsimple))
2690 return WEAK_LIST_SIMPLE;
2691 if (EQ(symbol, Qassoc))
2692 return WEAK_LIST_ASSOC;
2693 if (EQ(symbol, Qold_assoc))
2694 return WEAK_LIST_ASSOC; /* EBOLA ALERT! */
2695 if (EQ(symbol, Qkey_assoc))
2696 return WEAK_LIST_KEY_ASSOC;
2697 if (EQ(symbol, Qvalue_assoc))
2698 return WEAK_LIST_VALUE_ASSOC;
2699 if (EQ(symbol, Qfull_assoc))
2700 return WEAK_LIST_FULL_ASSOC;
2702 signal_simple_error("Invalid weak list type", symbol);
2703 return WEAK_LIST_SIMPLE; /* not reached */
2706 static Lisp_Object encode_weak_list_type(enum weak_list_type type)
2709 case WEAK_LIST_SIMPLE:
2711 case WEAK_LIST_ASSOC:
2713 case WEAK_LIST_KEY_ASSOC:
2715 case WEAK_LIST_VALUE_ASSOC:
2716 return Qvalue_assoc;
2717 case WEAK_LIST_FULL_ASSOC:
2723 return Qnil; /* not reached */
2726 DEFUN("weak-list-p", Fweak_list_p, 1, 1, 0, /*
2727 Return non-nil if OBJECT is a weak list.
2731 return WEAK_LISTP(object) ? Qt : Qnil;
2734 DEFUN("make-weak-list", Fmake_weak_list, 0, 1, 0, /*
2735 Return a new weak list object of type TYPE.
2736 A weak list object is an object that contains a list. This list behaves
2737 like any other list except that its elements do not count towards
2738 garbage collection -- if the only pointer to an object is inside a weak
2739 list (other than pointers in similar objects such as weak hash tables),
2740 the object is garbage collected and automatically removed from the list.
2741 This is used internally, for example, to manage the list holding the
2742 children of an extent -- an extent that is unused but has a parent will
2743 still be reclaimed, and will automatically be removed from its parent's
2746 Optional argument TYPE specifies the type of the weak list, and defaults
2747 to `simple'. Recognized types are
2749 `simple' Objects in the list disappear if not pointed to.
2750 `assoc' Objects in the list disappear if they are conses
2751 and either the car or the cdr of the cons is not
2753 `key-assoc' Objects in the list disappear if they are conses
2754 and the car is not pointed to.
2755 `value-assoc' Objects in the list disappear if they are conses
2756 and the cdr is not pointed to.
2757 `full-assoc' Objects in the list disappear if they are conses
2758 and neither the car nor the cdr is pointed to.
2765 return make_weak_list(decode_weak_list_type(type));
2768 DEFUN("weak-list-type", Fweak_list_type, 1, 1, 0, /*
2769 Return the type of the given weak-list object.
2773 CHECK_WEAK_LIST(weak);
2774 return encode_weak_list_type(XWEAK_LIST(weak)->type);
2777 DEFUN("weak-list-list", Fweak_list_list, 1, 1, 0, /*
2778 Return the list contained in a weak-list object.
2782 CHECK_WEAK_LIST(weak);
2783 return XWEAK_LIST_LIST(weak);
2786 DEFUN("set-weak-list-list", Fset_weak_list_list, 2, 2, 0, /*
2787 Change the list contained in a weak-list object.
2791 CHECK_WEAK_LIST(weak);
2792 XWEAK_LIST_LIST(weak) = new_list;
2796 /************************************************************************/
2797 /* initialization */
2798 /************************************************************************/
2800 static SIGTYPE arith_error(int signo)
2802 EMACS_REESTABLISH_SIGNAL(signo, arith_error);
2803 EMACS_UNBLOCK_SIGNAL(signo);
2804 signal_error(Qarith_error, Qnil);
2807 void init_data_very_early(void)
2809 /* Don't do this if just dumping out.
2810 We don't want to call `signal' in this case
2811 so that we don't have trouble with dumping
2812 signal-delivering routines in an inconsistent state. */
2816 #endif /* CANNOT_DUMP */
2817 signal(SIGFPE, arith_error);
2819 signal(SIGEMT, arith_error);
2824 init_errors_once_early (void)
2826 DEFSYMBOL (Qerror_conditions);
2827 DEFSYMBOL (Qerror_message);
2829 /* We declare the errors here because some other deferrors depend
2830 on some of the errors below. */
2832 /* ERROR is used as a signaler for random errors for which nothing
2835 DEFERROR (Qerror, "error", Qnil);
2836 DEFERROR_STANDARD (Qquit, Qnil);
2838 DEFERROR_STANDARD (Qinvalid_argument, Qerror);
2840 DEFERROR_STANDARD (Qsyntax_error, Qinvalid_argument);
2841 DEFERROR_STANDARD (Qinvalid_read_syntax, Qsyntax_error);
2842 DEFERROR_STANDARD (Qstructure_formation_error, Qsyntax_error);
2843 DEFERROR_STANDARD (Qlist_formation_error, Qstructure_formation_error);
2844 DEFERROR_STANDARD (Qmalformed_list, Qlist_formation_error);
2845 DEFERROR_STANDARD (Qmalformed_property_list, Qmalformed_list);
2846 DEFERROR_STANDARD (Qcircular_list, Qlist_formation_error);
2847 DEFERROR_STANDARD (Qcircular_property_list, Qcircular_list);
2849 DEFERROR_STANDARD (Qwrong_type_argument, Qinvalid_argument);
2850 DEFERROR_STANDARD (Qargs_out_of_range, Qinvalid_argument);
2851 DEFERROR_STANDARD (Qwrong_number_of_arguments, Qinvalid_argument);
2852 DEFERROR_STANDARD (Qinvalid_function, Qinvalid_argument);
2853 DEFERROR_STANDARD (Qinvalid_constant, Qinvalid_argument);
2854 DEFERROR (Qno_catch, "No catch for tag", Qinvalid_argument);
2856 DEFERROR_STANDARD (Qinvalid_state, Qerror);
2857 DEFERROR (Qvoid_function, "Symbol's function definition is void",
2859 DEFERROR (Qcyclic_function_indirection,
2860 "Symbol's chain of function indirections contains a loop",
2862 DEFERROR (Qvoid_variable, "Symbol's value as variable is void",
2864 DEFERROR (Qcyclic_variable_indirection,
2865 "Symbol's chain of variable indirections contains a loop",
2867 DEFERROR_STANDARD (Qstack_overflow, Qinvalid_state);
2868 DEFERROR_STANDARD (Qinternal_error, Qinvalid_state);
2869 DEFERROR_STANDARD (Qout_of_memory, Qinvalid_state);
2871 DEFERROR_STANDARD (Qinvalid_operation, Qerror);
2872 DEFERROR_STANDARD (Qinvalid_change, Qinvalid_operation);
2873 DEFERROR (Qsetting_constant, "Attempt to set a constant symbol",
2875 DEFERROR_STANDARD (Qprinting_unreadable_object, Qinvalid_operation);
2876 DEFERROR (Qunimplemented, "Feature not yet implemented", Qinvalid_operation);
2878 DEFERROR_STANDARD (Qediting_error, Qinvalid_operation);
2879 DEFERROR_STANDARD (Qbeginning_of_buffer, Qediting_error);
2880 DEFERROR_STANDARD (Qend_of_buffer, Qediting_error);
2881 DEFERROR (Qbuffer_read_only, "Buffer is read-only", Qediting_error);
2883 DEFERROR (Qio_error, "IO Error", Qinvalid_operation);
2884 DEFERROR_STANDARD (Qfile_error, Qio_error);
2885 DEFERROR (Qend_of_file, "End of file or stream", Qfile_error);
2886 DEFERROR_STANDARD (Qconversion_error, Qio_error);
2887 DEFERROR_STANDARD (Qtext_conversion_error, Qconversion_error);
2889 DEFERROR (Qarith_error, "Arithmetic error", Qinvalid_operation);
2890 DEFERROR (Qrange_error, "Arithmetic range error", Qarith_error);
2891 DEFERROR (Qdomain_error, "Arithmetic domain error", Qarith_error);
2892 DEFERROR (Qsingularity_error, "Arithmetic singularity error", Qdomain_error);
2893 DEFERROR (Qoverflow_error, "Arithmetic overflow error", Qdomain_error);
2894 DEFERROR (Qunderflow_error, "Arithmetic underflow error", Qdomain_error);
2897 void syms_of_data(void)
2899 INIT_LRECORD_IMPLEMENTATION(weak_list);
2904 DEFSYMBOL(Qtrue_list_p);
2907 DEFSYMBOL(Qsymbolp);
2908 DEFSYMBOL(Qintegerp);
2909 DEFSYMBOL(Qcharacterp);
2910 DEFSYMBOL(Qnatnump);
2911 DEFSYMBOL(Qnonnegativep);
2912 DEFSYMBOL(Qpositivep);
2913 DEFSYMBOL(Qstringp);
2915 DEFSYMBOL(Qsequencep);
2917 DEFSYMBOL(Qbufferp);
2919 DEFSYMBOL_MULTIWORD_PREDICATE(Qbit_vectorp);
2920 DEFSYMBOL(Qvectorp);
2921 DEFSYMBOL(Qchar_or_string_p);
2922 DEFSYMBOL(Qmarkerp);
2923 DEFSYMBOL(Qinteger_or_marker_p);
2924 DEFSYMBOL(Qinteger_or_char_p);
2925 DEFSYMBOL(Qinteger_char_or_marker_p);
2926 DEFSYMBOL(Qnumberp);
2927 DEFSYMBOL(Qnumber_char_or_marker_p);
2929 DEFSYMBOL_MULTIWORD_PREDICATE(Qweak_listp);
2933 #endif /* HAVE_FPFLOAT */
2935 DEFSUBR(Fwrong_type_argument);
2940 Ffset(intern("not"), intern("null"));
2943 DEFSUBR(Ftrue_list_p);
2946 DEFSUBR(Fchar_or_string_p);
2947 DEFSUBR(Fcharacterp);
2948 DEFSUBR(Fchar_int_p);
2949 DEFSUBR(Fchar_to_int);
2950 DEFSUBR(Fint_to_char);
2951 DEFSUBR(Fchar_or_char_int_p);
2954 DEFSUBR(Finteger_or_marker_p);
2955 DEFSUBR(Finteger_or_char_p);
2956 DEFSUBR(Finteger_char_or_marker_p);
2958 DEFSUBR(Fnumber_or_marker_p);
2959 DEFSUBR(Fnumber_char_or_marker_p);
2962 #endif /* HAVE_FPFLOAT */
2964 DEFSUBR(Fnonnegativep);
2970 DEFSUBR(Fbit_vector_p);
2972 DEFSUBR(Fsequencep);
2975 DEFSUBR(Fsubr_min_args);
2976 DEFSUBR(Fsubr_max_args);
2977 DEFSUBR(Fsubr_interactive);
2985 DEFSUBR(Findirect_function);
2989 DEFSUBR(Fnumber_to_string);
2990 DEFSUBR(Fstring_to_number);
2998 #if defined(WITH_GMP) && defined(HAVE_MPZ)
3000 DEFSUBR(Fnext_prime);
3004 DEFSUBR(Ffactorial);
3005 DEFSUBR(Fbinomial_coefficient);
3006 DEFSUBR(Fremove_factor);
3007 DEFSUBR(Ffibonacci);
3008 DEFSUBR(Ffibonacci2);
3011 DEFSUBR(Fdivisiblep);
3012 DEFSUBR(Fcongruentp);
3013 DEFSUBR(Fperfect_power_p);
3014 DEFSUBR(Fperfect_square_p);
3015 DEFSUBR(Fintegral_sqrt);
3016 #if defined HAVE_ECM && defined WITH_ECM
3017 DEFSUBR(Ffactorise); /* some day maybe */
3018 #endif /* WITH_ECM && HAVE_ECM */
3019 #endif /* WITH_GMP && HAVE_MPZ */
3020 DEFSUBR(Fzero_divisor_p);
3021 DEFSUBR(Fweak_list_p);
3022 DEFSUBR(Fmake_weak_list);
3023 DEFSUBR(Fweak_list_type);
3024 DEFSUBR(Fweak_list_list);
3025 DEFSUBR(Fset_weak_list_list);
3028 void vars_of_data(void)
3030 /* This must not be staticpro'd */
3031 Vall_weak_lists = Qnil;
3032 dump_add_weak_object_chain(&Vall_weak_lists);
3034 #ifdef DEBUG_SXEMACS
3035 DEFVAR_BOOL("debug-issue-ebola-notices", &debug_issue_ebola_notices /*
3036 If non-zero, note when your code may be suffering from char-int confoundance.
3037 That is to say, if SXEmacs encounters a usage of `eq', `memq', `equal',
3038 etc. where an int and a char with the same value are being compared,
3039 it will issue a notice on stderr to this effect, along with a backtrace.
3040 In such situations, the result would be different in XEmacs 19 versus
3041 XEmacs 20, and you probably don't want this.
3043 Note that in order to see these notices, you have to byte compile your
3044 code under XEmacs 20 -- any code byte-compiled under XEmacs 19 will
3045 have its chars and ints all confounded in the byte code, making it
3046 impossible to accurately determine Ebola infection.
3049 debug_issue_ebola_notices = 0;
3051 DEFVAR_INT("debug-ebola-backtrace-length", &debug_ebola_backtrace_length /*
3052 Length (in stack frames) of short backtrace printed out in Ebola notices.
3053 See `debug-issue-ebola-notices'.
3055 debug_ebola_backtrace_length = 32;
3057 #endif /* DEBUG_SXEMACS */