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"
35 Lisp_Object Qnil, Qt, Qquote, Qlambda, Qunbound;
36 Lisp_Object Qerror_conditions, Qerror_message;
37 Lisp_Object Qerror, Qquit, Qsyntax_error, Qinvalid_read_syntax;
38 Lisp_Object Qlist_formation_error, Qstructure_formation_error;
39 Lisp_Object Qmalformed_list, Qmalformed_property_list;
40 Lisp_Object Qcircular_list, Qcircular_property_list;
41 Lisp_Object Qinvalid_argument, Qwrong_type_argument, Qargs_out_of_range;
42 Lisp_Object Qwrong_number_of_arguments, Qinvalid_function, Qno_catch;
43 Lisp_Object Qinternal_error, Qinvalid_state, Qinvalid_constant;
44 Lisp_Object Qvoid_variable, Qcyclic_variable_indirection;
45 Lisp_Object Qvoid_function, Qcyclic_function_indirection;
46 Lisp_Object Qinvalid_operation, Qinvalid_change, Qout_of_memory;
47 Lisp_Object Qsetting_constant, Qprinting_unreadable_object;
48 Lisp_Object Qediting_error, Qconversion_error, Qtext_conversion_error;
49 Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only;
50 Lisp_Object Qio_error, Qend_of_file;
51 Lisp_Object Qarith_error, Qrange_error, Qdomain_error, Qstack_overflow;
52 Lisp_Object Qsingularity_error, Qoverflow_error, Qunderflow_error;
53 Lisp_Object Qintegerp, Qnatnump, Qnonnegativep, Qpositivep, Qsymbolp;
54 Lisp_Object Qlistp, Qtrue_list_p, Qweak_listp;
55 Lisp_Object Qconsp, Qsubrp;
56 Lisp_Object Qcharacterp, Qstringp, Qarrayp, Qsequencep, Qvectorp, Qdictp;
57 Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qbufferp;
58 Lisp_Object Qinteger_or_char_p, Qinteger_char_or_marker_p;
59 Lisp_Object Qnumberp, Qnumber_char_or_marker_p;
60 Lisp_Object Qbit_vectorp, Qbitp, Qcdr;
66 int debug_issue_ebola_notices;
68 Fixnum debug_ebola_backtrace_length;
70 int eq_with_ebola_notice(Lisp_Object obj1, Lisp_Object obj2)
72 if (debug_issue_ebola_notices
73 && ((CHARP(obj1) && INTP(obj2)) || (CHARP(obj2) && INTP(obj1)))) {
74 /* #### It would be really nice if this were a proper warning
75 instead of brain-dead print to Qexternal_debugging_output. */
77 ("Comparison between integer and character is constant nil (",
78 Qexternal_debugging_output);
79 Fprinc(obj1, Qexternal_debugging_output);
80 write_c_string(" and ", Qexternal_debugging_output);
81 Fprinc(obj2, Qexternal_debugging_output);
82 write_c_string(")\n", Qexternal_debugging_output);
83 debug_short_backtrace(debug_ebola_backtrace_length);
85 return EQ(obj1, obj2);
88 #endif /* DEBUG_SXEMACS */
90 Lisp_Object wrong_type_argument(Lisp_Object predicate, Lisp_Object value)
92 /* This function can GC */
93 REGISTER Lisp_Object tem;
95 value = Fsignal(Qwrong_type_argument, list2(predicate, value));
96 tem = call1(predicate, value);
102 DOESNT_RETURN dead_wrong_type_argument(Lisp_Object predicate, Lisp_Object value)
104 signal_error(Qwrong_type_argument, list2(predicate, value));
107 DEFUN("wrong-type-argument", Fwrong_type_argument, 2, 2, 0, /*
108 Signal an error until the correct type value is given by the user.
109 This function loops, signalling a continuable `wrong-type-argument' error
110 with PREDICATE and VALUE as the data associated with the error and then
111 calling PREDICATE on the returned value, until the value gotten satisfies
112 PREDICATE. At that point, the gotten value is returned.
116 return wrong_type_argument(predicate, value);
119 DOESNT_RETURN c_write_error(Lisp_Object obj)
121 signal_simple_error("Attempt to modify read-only object (c)", obj);
124 DOESNT_RETURN lisp_write_error(Lisp_Object obj)
126 signal_simple_error("Attempt to modify read-only object (lisp)", obj);
129 DOESNT_RETURN args_out_of_range(Lisp_Object a1, Lisp_Object a2)
131 signal_error(Qargs_out_of_range, list2(a1, a2));
135 args_out_of_range_3(Lisp_Object a1, Lisp_Object a2, Lisp_Object a3)
137 signal_error(Qargs_out_of_range, list3(a1, a2, a3));
140 void check_int_range(EMACS_INT val, EMACS_INT min, EMACS_INT max)
142 if (val < min || val > max)
143 args_out_of_range_3(make_int(val), make_int(min),
147 /* On some machines, XINT needs a temporary location.
148 Here it is, in case it is needed. */
150 EMACS_INT sign_extend_temp;
152 /* On a few machines, XINT can only be done by calling this. */
153 /* SXEmacs: only used by m/convex.h */
154 EMACS_INT sign_extend_lisp_int(EMACS_INT num);
155 EMACS_INT sign_extend_lisp_int(EMACS_INT num)
157 if (num & (1L << (INT_VALBITS - 1)))
158 return num | ((-1L) << INT_VALBITS);
160 return num & (EMACS_INT) ((1UL << INT_VALBITS) - 1);
163 /* Data type predicates */
165 DEFUN("eq", Feq, 2, 2, 0, /*
166 Return t if the two args are the same Lisp object.
170 return EQ_WITH_EBOLA_NOTICE(object1, object2) ? Qt : Qnil;
173 DEFUN("old-eq", Fold_eq, 2, 2, 0, /*
174 Return t if the two args are (in most cases) the same Lisp object.
176 Special kludge: A character is considered `old-eq' to its equivalent integer
177 even though they are not the same object and are in fact of different
178 types. This is ABSOLUTELY AND UTTERLY HORRENDOUS but is necessary to
179 preserve byte-code compatibility with v19. This kludge is known as the
180 \"char-int confoundance disease\" and appears in a number of other
181 functions with `old-foo' equivalents.
183 Do not use this function!
188 return HACKEQ_UNSAFE(object1, object2) ? Qt : Qnil;
191 DEFUN("null", Fnull, 1, 1, 0, /*
192 Return t if OBJECT is nil.
196 return NILP(object) ? Qt : Qnil;
199 DEFUN("consp", Fconsp, 1, 1, 0, /*
200 Return t if OBJECT is a cons cell. `nil' is not a cons cell.
202 A cons cell is a Lisp object (an area in memory) comprising two pointers
203 called the CAR and the CDR. Each of these pointers can point to any other
204 Lisp object. The common Lisp data type, the list, is a specially-structured
205 series of cons cells.
207 See the documentation for `cons' or the Lisp manual for more details on what
212 return CONSP(object) ? Qt : Qnil;
215 DEFUN("atom", Fatom, 1, 1, 0, /*
216 Return t if OBJECT is not a cons cell. `nil' is not a cons cell.
218 A cons cell is a Lisp object (an area in memory) comprising two pointers
219 called the CAR and the CDR. Each of these pointers can point to any other
220 Lisp object. The common Lisp data type, the list, is a specially-structured
221 series of cons cells.
223 See the documentation for `cons' or the Lisp manual for more details on what
228 return CONSP(object) ? Qnil : Qt;
231 DEFUN("listp", Flistp, 1, 1, 0, /*
232 Return t if OBJECT is a list. `nil' is a list.
234 A list is implemented as a series of cons cells structured such that the CDR
235 of each cell either points to another cons cell or to `nil', the special
236 Lisp value for both Boolean false and the empty list.
240 return LISTP(object) ? Qt : Qnil;
243 DEFUN("nlistp", Fnlistp, 1, 1, 0, /*
244 Return t if OBJECT is not a list. `nil' is a list.
246 A list is implemented as a series of cons cells structured such that the CDR
247 of each cell either points to another cons cell or to `nil', the special
248 Lisp value for both Boolean false and the empty list.
252 return LISTP(object) ? Qnil : Qt;
255 DEFUN("true-list-p", Ftrue_list_p, 1, 1, 0, /*
256 Return t if OBJECT is an acyclic, nil-terminated (ie, not dotted), list.
258 A list is implemented as a series of cons cells structured such that the CDR
259 of each cell either points to another cons cell or to `nil', the special
260 Lisp value for both Boolean false and the empty list.
264 return TRUE_LIST_P(object) ? Qt : Qnil;
267 DEFUN("symbolp", Fsymbolp, 1, 1, 0, /*
268 Return t if OBJECT is a symbol.
272 return SYMBOLP(object) ? Qt : Qnil;
275 DEFUN("keywordp", Fkeywordp, 1, 1, 0, /*
276 Return t if OBJECT is a keyword.
278 A symbol is a Lisp object with a name. It can optionally have any and all of
279 a value, a property list and an associated function.
283 return KEYWORDP(object) ? Qt : Qnil;
286 DEFUN("vectorp", Fvectorp, 1, 1, 0, /*
287 Return t if OBJECT is a vector.
291 return VECTORP(object) ? Qt : Qnil;
294 DEFUN("bit-vector-p", Fbit_vector_p, 1, 1, 0, /*
295 Return t if OBJECT is a bit vector.
299 return BIT_VECTORP(object) ? Qt : Qnil;
302 DEFUN("stringp", Fstringp, 1, 1, 0, /*
303 Return t if OBJECT is a string.
307 return STRINGP(object) ? Qt : Qnil;
310 DEFUN("arrayp", Farrayp, 1, 1, 0, /*
311 Return t if OBJECT is an array (string, vector, or bit vector).
315 return (VECTORP(object) || STRINGP(object) || BIT_VECTORP(object))
319 DEFUN("sequencep", Fsequencep, 1, 1, 0, /*
320 Return t if OBJECT is a sequence (list, dllist or array).
324 return (LISTP(object) || DLLISTP(object) ||
325 VECTORP(object) || STRINGP(object) || BIT_VECTORP(object))
329 DEFUN("markerp", Fmarkerp, 1, 1, 0, /*
330 Return t if OBJECT is a marker (editor pointer).
334 return MARKERP(object) ? Qt : Qnil;
337 DEFUN("subrp", Fsubrp, 1, 1, 0, /*
338 Return t if OBJECT is a built-in function.
342 return SUBRP(object) ? Qt : Qnil;
345 DEFUN("subr-min-args", Fsubr_min_args, 1, 1, 0, /*
346 Return minimum number of args built-in function SUBR may be called with.
351 return make_int(XSUBR(subr)->min_args);
354 DEFUN("subr-max-args", Fsubr_max_args, 1, 1, 0, /*
355 Return maximum number of args built-in function SUBR may be called with,
356 or nil if it takes an arbitrary number of arguments or is a special form.
362 nargs = XSUBR(subr)->max_args;
363 if (nargs == MANY || nargs == UNEVALLED)
366 return make_int(nargs);
369 DEFUN("subr-interactive", Fsubr_interactive, 1, 1, 0, /*
370 Return the interactive spec of the subr object SUBR, or nil.
371 If non-nil, the return value will be a list whose first element is
372 `interactive' and whose second element is the interactive spec.
378 prompt = XSUBR(subr)->prompt;
379 return prompt ? list2(Qinteractive, build_string(prompt)) : Qnil;
382 DEFUN("characterp", Fcharacterp, 1, 1, 0, /*
383 Return t if OBJECT is a character.
384 Unlike in XEmacs v19 and FSF Emacs, a character is its own primitive type.
385 Any character can be converted into an equivalent integer using
386 `char-int'. To convert the other way, use `int-char'; however,
387 only some integers can be converted into characters. Such an integer
388 is called a `char-int'; see `char-int-p'.
390 Some functions that work on integers (e.g. the comparison functions
391 <, <=, =, /=, etc. and the arithmetic functions +, -, *, etc.)
392 accept characters and implicitly convert them into integers. In
393 general, functions that work on characters also accept char-ints and
394 implicitly convert them into characters. WARNING: Neither of these
395 behaviors is very desirable, and they are maintained for backward
396 compatibility with old E-Lisp programs that confounded characters and
397 integers willy-nilly. These behaviors may change in the future; therefore,
398 do not rely on them. Instead, use the character-specific functions such
403 return CHARP(object) ? Qt : Qnil;
406 DEFUN("char-to-int", Fchar_to_int, 1, 1, 0, /*
407 Convert CHARACTER into an equivalent integer.
408 The resulting integer will always be non-negative. The integers in
409 the range 0 - 255 map to characters as follows:
413 128 - 159 Control set 1
414 160 - 255 Right half of ISO-8859-1
416 If support for Mule does not exist, these are the only valid character
417 values. When Mule support exists, the values assigned to other characters
418 may vary depending on the particular version of SXEmacs, the order in which
419 character sets were loaded, etc., and you should not depend on them.
423 CHECK_CHAR(character);
424 return make_int(XCHAR(character));
427 DEFUN("int-to-char", Fint_to_char, 1, 1, 0, /*
428 Convert integer INTEGER into the equivalent character.
429 Not all integers correspond to valid characters; use `char-int-p' to
430 determine whether this is the case. If the integer cannot be converted,
436 if (CHAR_INTP(integer))
437 return make_char(XINT(integer));
442 DEFUN("char-int-p", Fchar_int_p, 1, 1, 0, /*
443 Return t if OBJECT is an integer that can be converted into a character.
448 return CHAR_INTP(object) ? Qt : Qnil;
451 DEFUN("char-or-char-int-p", Fchar_or_char_int_p, 1, 1, 0, /*
452 Return t if OBJECT is a character or an integer that can be converted into one.
456 return CHAR_OR_CHAR_INTP(object) ? Qt : Qnil;
459 DEFUN("char-or-string-p", Fchar_or_string_p, 1, 1, 0, /*
460 Return t if OBJECT is a character (or a char-int) or a string.
461 It is semi-hateful that we allow a char-int here, as it goes against
462 the name of this function, but it makes the most sense considering the
463 other steps we take to maintain compatibility with the old character/integer
464 confoundedness in older versions of E-Lisp.
468 return CHAR_OR_CHAR_INTP(object) || STRINGP(object) ? Qt : Qnil;
471 #ifdef WITH_NUMBER_TYPES
472 /* In this case, integerp is defined in number.c. */
473 DEFUN("intp", Fintp, 1, 1, 0, /*
474 Return t if OBJECT is an ordinary integer.
478 return INTP(object) ? Qt : Qnil;
480 /* stay compatible to XE 21.5 */
481 DEFUN("fixnump", Ffixnump, 1, 1, 0, /*
482 Return t if OBJECT is an ordinary integer.
486 return INTP(object) ? Qt : Qnil;
488 #else /* !WITH_NUMBER_TYPES */
489 DEFUN("integerp", Fintegerp, 1, 1, 0, /*
490 Return t if OBJECT is an integer.
494 return INTP(object) ? Qt : Qnil;
496 #endif /* WITH_NUMBER_TYPES */
498 DEFUN("integer-or-marker-p", Finteger_or_marker_p, 1, 1, 0, /*
499 Return t if OBJECT is an integer or a marker (editor pointer).
503 return INTP(object) || MARKERP(object) ? Qt : Qnil;
506 DEFUN("integer-or-char-p", Finteger_or_char_p, 1, 1, 0, /*
507 Return t if OBJECT is an integer or a character.
511 return INTP(object) || CHARP(object) ? Qt : Qnil;
514 DEFUN("integer-char-or-marker-p", Finteger_char_or_marker_p, 1, 1, 0, /*
515 Return t if OBJECT is an integer, character or a marker (editor pointer).
519 return INTP(object) || CHARP(object) || MARKERP(object) ? Qt : Qnil;
522 DEFUN("natnump", Fnatnump, 1, 1, 0, /*
523 Return t if OBJECT is a nonnegative integer.
527 return (NATNUMP(object)
528 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
530 bigz_sign(XBIGZ_DATA(object)) >= 0)
535 DEFUN ("nonnegativep", Fnonnegativep, 1, 1, 0, /*
536 Return t if OBJECT is a nonnegative number.
538 We call a number object non-negative iff it is comparable
539 and its value is not less than 0.
543 return NATNUMP(object)
544 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
546 bigz_sign(XBIGZ_DATA(object)) >= 0)
547 #endif /* HAVE_MPZ */
548 #if defined HAVE_MPQ && defined WITH_GMP
550 bigq_sign(XBIGQ_DATA(object)) >= 0)
551 #endif /* HAVE_MPQ */
553 || (FLOATP(object) &&
554 (double)XFLOAT_DATA(object) >= 0.0)
555 #endif /* HAVE_FPFLOAT */
556 #if defined HAVE_MPF && defined WITH_GMP
558 bigf_sign(XBIGF_DATA(object)) >= 0)
559 #endif /* HAVE_MPF */
560 #if defined HAVE_MPFR && defined WITH_MPFR
561 || (BIGFRP(object) &&
562 bigfr_sign(XBIGFR_DATA(object)) >= 0)
563 #endif /* HAVE_MPFR */
567 DEFUN("bitp", Fbitp, 1, 1, 0, /*
568 Return t if OBJECT is a bit (0 or 1).
572 return BITP(object) ? Qt : Qnil;
575 DEFUN("numberp", Fnumberp, 1, 1, 0, /*
576 Return t if OBJECT is a number (floating point or integer).
580 #if defined(WITH_NUMBER_TYPES)
581 return NUMBERP(object) ? Qt : Qnil;
583 return INT_OR_FLOATP(object) ? Qt : Qnil;
587 DEFUN("number-or-marker-p", Fnumber_or_marker_p, 1, 1, 0, /*
588 Return t if OBJECT is a number or a marker.
592 return INT_OR_FLOATP(object) || MARKERP(object) ? Qt : Qnil;
595 DEFUN("number-char-or-marker-p", Fnumber_char_or_marker_p, 1, 1, 0, /*
596 Return t if OBJECT is a number, character or a marker.
600 return (INT_OR_FLOATP(object) || CHARP(object) || MARKERP(object))
605 DEFUN("floatp", Ffloatp, 1, 1, 0, /*
606 Return t if OBJECT is a floating point number.
610 return FLOATP(object) ? Qt : Qnil;
612 #endif /* HAVE_FPFLOAT */
614 DEFUN("type-of", Ftype_of, 1, 1, 0, /*
615 Return a symbol representing the type of OBJECT.
619 switch (XTYPE(object)) {
620 case Lisp_Type_Record:
621 if (XRECORD_LHEADER_IMPLEMENTATION(object)->
622 lrecord_type_index != lrecord_type_dynacat)
624 XRECORD_LHEADER_IMPLEMENTATION(object)->name);
625 else if (SYMBOLP(XDYNACAT_TYPE(object)))
626 return XDYNACAT_TYPE(object);
634 case Lisp_Type_Int_Even:
635 case Lisp_Type_Int_Odd:
641 /* Extract and set components of lists */
643 DEFUN("car", Fcar, 1, 1, 0, /*
644 Return the car of CONS. If CONS is nil, return nil.
646 The car of a list or a dotted pair is its first element.
647 Error if CONS is not nil and not a cons cell. See also `car-safe'.
657 cons = wrong_type_argument(Qlistp, cons);
661 DEFUN("car-safe", Fcar_safe, 1, 1, 0, /*
662 Return the car of OBJECT if it is a cons cell, or else nil.
664 The car of a list or a dotted pair is its first element.
668 return CONSP(object) ? XCAR(object) : Qnil;
671 DEFUN("cdr", Fcdr, 1, 1, 0, /*
672 Return the cdr of CONS. If CONS is nil, return nil.
674 The cdr of a list is the list without its first element. The cdr of a
675 dotted pair (A . B) is the second element, B.
677 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
687 cons = wrong_type_argument(Qlistp, cons);
691 DEFUN("cdr-safe", Fcdr_safe, 1, 1, 0, /*
692 Return the cdr of OBJECT if it is a cons cell, else nil.
694 The cdr of a list is the list without its first element. The cdr of a
695 dotted pair (A . B) is the second element, B.
699 return CONSP(object) ? XCDR(object) : Qnil;
702 DEFUN("setcar", Fsetcar, 2, 2, 0, /*
703 Set the car of CONS-CELL to be NEWCAR. Return NEWCAR.
705 The car of a list or a dotted pair is its first element.
709 if (!CONSP(cons_cell))
710 cons_cell = wrong_type_argument(Qconsp, cons_cell);
712 XCAR(cons_cell) = newcar;
716 DEFUN("setcdr", Fsetcdr, 2, 2, 0, /*
717 Set the cdr of CONS-CELL to be NEWCDR. Return NEWCDR.
719 The cdr of a list is the list without its first element. The cdr of a
720 dotted pair (A . B) is the second element, B.
724 if (!CONSP(cons_cell))
725 cons_cell = wrong_type_argument(Qconsp, cons_cell);
727 XCDR(cons_cell) = newcdr;
731 /* Find the function at the end of a chain of symbol function indirections.
733 If OBJECT is a symbol, find the end of its function chain and
734 return the value found there. If OBJECT is not a symbol, just
735 return it. If there is a cycle in the function chain, signal a
736 cyclic-function-indirection error.
738 This is like Findirect_function when VOID_FUNCTION_ERRORP is true.
739 When VOID_FUNCTION_ERRORP is false, no error is signaled if the end
740 of the chain ends up being Qunbound. */
741 Lisp_Object indirect_function(Lisp_Object object, int void_function_errorp)
743 #define FUNCTION_INDIRECTION_SUSPICION_LENGTH 16
744 Lisp_Object tortoise, hare;
747 for (hare = tortoise = object, count = 0;
748 SYMBOLP(hare); hare = XSYMBOL(hare)->function, count++) {
749 if (count < FUNCTION_INDIRECTION_SUSPICION_LENGTH)
753 tortoise = XSYMBOL(tortoise)->function;
754 if (EQ(hare, tortoise))
755 return Fsignal(Qcyclic_function_indirection,
759 if (void_function_errorp && UNBOUNDP(hare))
760 return signal_void_function_error(object);
765 DEFUN("indirect-function", Findirect_function, 1, 1, 0, /*
766 Return the function at the end of OBJECT's function chain.
767 If OBJECT is a symbol, follow all function indirections and return
768 the final function binding.
769 If OBJECT is not a symbol, just return it.
770 Signal a void-function error if the final symbol is unbound.
771 Signal a cyclic-function-indirection error if there is a loop in the
772 function chain of symbols.
776 return indirect_function(object, 1);
779 /* Extract and set vector and string elements */
781 DEFUN("aref", Faref, 2, 2, 0, /*
782 Return the element of ARRAY at index INDEX.
783 ARRAY may be a vector, bit vector, or string. INDEX starts at 0.
791 /* frob the position INDEX */
794 else if (CHARP(index_))
795 idx = XCHAR(index_); /* yuck! */
797 index_ = wrong_type_argument(Qinteger_or_char_p, index_);
801 /* frob the length of ARRAY */
803 alen = XVECTOR_LENGTH(array);
804 else if (BIT_VECTORP(array))
805 alen = bit_vector_length(XBIT_VECTOR(array));
806 else if (STRINGP(array))
807 alen = XSTRING_CHAR_LENGTH(array);
811 if (idx < 0 || idx >= alen)
815 return XVECTOR_DATA(array)[idx];
816 else if (BIT_VECTORP(array))
817 return make_int(bit_vector_bit(XBIT_VECTOR(array), idx));
818 else if (STRINGP(array))
819 return make_char(string_char(XSTRING(array), idx));
820 #ifdef LOSING_BYTECODE
821 else if (COMPILED_FUNCTIONP(array)) {
822 /* Weird, gross compatibility kludge */
823 return Felt(array, index_);
827 check_losing_bytecode("aref", array);
828 array = wrong_type_argument(Qarrayp, array);
833 args_out_of_range(array, index_);
834 return Qnil; /* not reached */
837 DEFUN("aset", Faset, 3, 3, 0, /*
838 Store into the element of ARRAY at index INDEX the value NEWVAL.
839 ARRAY may be a vector, bit vector, or string. INDEX starts at 0.
841 (array, index_, newval))
847 /* frob the INDEX position */
850 else if (CHARP(index_))
851 idx = XCHAR(index_); /* yuck! */
853 index_ = wrong_type_argument(Qinteger_or_char_p, index_);
857 /* frob the length of ARRAY */
859 alen = XVECTOR_LENGTH(array);
860 else if (BIT_VECTORP(array))
861 alen = bit_vector_length(XBIT_VECTOR(array));
862 else if (STRINGP(array))
863 alen = XSTRING_CHAR_LENGTH(array);
867 if (idx < 0 || idx >= alen)
870 if (VECTORP(array)) {
871 XVECTOR_DATA(array)[idx] = newval;
872 } else if (BIT_VECTORP(array)) {
874 set_bit_vector_bit(XBIT_VECTOR(array), idx, !ZEROP(newval));
875 } else if (STRINGP(array)) {
876 CHECK_CHAR_COERCE_INT(newval);
877 set_string_char(XSTRING(array), idx, XCHAR(newval));
878 bump_string_modiff(array);
880 array = wrong_type_argument(Qarrayp, array);
887 args_out_of_range(array, index_);
888 return Qnil; /* not reached */
891 /**********************************************************************/
892 /* Arithmetic functions */
893 /**********************************************************************/
902 #ifndef WITH_NUMBER_TYPES
904 number_char_or_marker_to_int_or_double(Lisp_Object obj, int_or_double * p)
909 p->c.ival = XINT(obj);
911 p->c.ival = XCHAR(obj);
912 else if (MARKERP(obj))
913 p->c.ival = marker_position(obj);
915 else if (FLOATP(obj))
916 p->c.dval = XFLOAT_DATA(obj), p->int_p = 0;
919 obj = wrong_type_argument(Qnumber_char_or_marker_p, obj);
924 static double number_char_or_marker_to_double(Lisp_Object obj)
928 return (double)XINT(obj);
930 return (double)XCHAR(obj);
931 else if (MARKERP(obj))
932 return (double)marker_position(obj);
934 else if (FLOATP(obj))
935 return XFLOAT_DATA(obj);
938 obj = wrong_type_argument(Qnumber_char_or_marker_p, obj);
944 static EMACS_INT integer_char_or_marker_to_int(Lisp_Object obj)
951 else if (MARKERP(obj))
952 return marker_position(obj);
954 obj = wrong_type_argument(Qinteger_char_or_marker_p, obj);
960 /* Convert between a 32-bit value and a cons of two 16-bit values.
961 This is used to pass 32-bit integers to and from the user.
962 Use time_to_lisp() and lisp_to_time() for time values.
964 If you're thinking of using this to store a pointer into a Lisp Object
965 for internal purposes (such as when calling record_unwind_protect()),
966 try using make_opaque_ptr()/get_opaque_ptr() instead. */
967 Lisp_Object word_to_lisp(unsigned int item)
969 return Fcons(make_int(item >> 16), make_int(item & 0xffff));
972 unsigned int lisp_to_word(Lisp_Object item)
977 Lisp_Object top = Fcar(item);
978 Lisp_Object bot = Fcdr(item);
981 return (XINT(top) << 16) | (XINT(bot) & 0xffff);
985 DEFUN("number-to-string", Fnumber_to_string, 1, 1, 0, /*
986 Convert NUMBER to a string by printing it in decimal.
987 Uses a minus sign if negative.
988 NUMBER may be an integer or a floating point number.
992 char buffer[VALBITS];
994 #ifdef WITH_NUMBER_TYPES
995 CHECK_NUMBER(number);
997 CHECK_INT_OR_FLOAT(number);
1001 if (FLOATP(number)) {
1002 char pigbuf[350]; /* see comments in float_to_string */
1004 float_to_string(pigbuf, XFLOAT_DATA(number));
1005 return build_string(pigbuf);
1007 #endif /* HAVE_FPFLOAT */
1008 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1009 if (BIGZP(number)) {
1010 char *str = bigz_to_string(XBIGZ_DATA(number), 10);
1011 Lisp_Object retval = build_string(str);
1015 #endif /* HAVE_MPZ */
1016 #if defined HAVE_MPQ && defined WITH_GMP
1017 if (BIGQP(number)) {
1018 char *str = (char *)bigq_to_string(XBIGQ_DATA(number), 10);
1019 Lisp_Object retval = build_string(str);
1023 #endif /* HAVE_MPQ */
1024 #if defined HAVE_MPF && defined WITH_GMP
1025 if (BIGFP(number)) {
1026 char *str = (char *)bigf_to_string(XBIGF_DATA(number), 10);
1027 Lisp_Object retval = build_string(str);
1031 #endif /* HAVE_MPF */
1032 #if defined HAVE_MPFR && defined WITH_MPFR
1033 if (BIGFRP(number)) {
1034 char *str = (char*)bigfr_to_string(XBIGFR_DATA(number), 10);
1035 Lisp_Object retval = build_string(str);
1039 #endif /* HAVE_MPFR */
1040 #if defined HAVE_PSEUG && defined WITH_PSEUG
1041 if (BIGGP(number)) {
1042 char *str = (char *)bigg_to_string(XBIGG_DATA(number), 10);
1043 Lisp_Object retval = build_string(str);
1047 #endif /* HAVE_PSEUG */
1048 #if defined HAVE_MPC && defined WITH_MPC || \
1049 defined HAVE_PSEUC && defined WITH_PSEUC
1050 if (BIGCP(number)) {
1051 char *str = (char *)bigc_to_string(XBIGC_DATA(number), 10);
1052 Lisp_Object retval = build_string(str);
1056 #endif /* HAVE_MPC */
1057 #if defined HAVE_QUATERN && defined WITH_QUATERN
1058 if (QUATERNP(number)) {
1059 char *str = (char*)quatern_to_string(XQUATERN_DATA(number), 10);
1060 Lisp_Object retval = build_string(str);
1064 #endif /* HAVE_QUATERN */
1065 if (INDEFP(number)) {
1066 char *str = (char *)indef_to_string(XINDEF_DATA(number));
1067 Lisp_Object retval = build_string(str);
1072 long_to_string(buffer, XINT(number));
1073 return build_string(buffer);
1076 #if !defined HAVE_MPZ || !(defined WITH_GMP || defined WITH_MP)
1077 static int digit_to_number(int character, int base)
1080 int digit = ((character >= '0' && character <= '9') ? character - '0' :
1083 'z') ? character - 'a' + 10 : (character >= 'A'
1085 'Z') ? character - 'A' +
1088 return digit >= base ? -1 : digit;
1090 #endif /* HAVE_MPZ */
1092 DEFUN("string-to-number", Fstring_to_number, 1, 2, 0, /*
1093 Convert STRING to a number by parsing it as a number in base BASE.
1094 This parses both integers and floating point numbers.
1095 It ignores leading spaces and tabs.
1097 If BASE is nil or omitted, base 10 is used.
1098 BASE must be an integer between 2 and 16 (inclusive).
1099 Floating point numbers always use base 10.
1101 If STRING is a float, the variable `read-real-as' decides how to
1102 interpret that float.
1109 CHECK_STRING(string);
1116 check_int_range(b, 2, 16);
1119 p = (char *)XSTRING_DATA(string);
1121 /* Skip any whitespace at the front of the number. Some versions of
1122 atoi do this anyway, so we might as well make Emacs lisp consistent. */
1123 while (*p == ' ' || *p == '\t')
1126 #if defined HAVE_PSEUG && defined WITH_PSEUG
1127 if (isgaussian_string(p))
1128 return read_bigg_string(p);
1129 #endif /* HAVE_PSEUG */
1131 #if defined HAVE_MPC && defined WITH_MPC || \
1132 defined HAVE_PSEUC && defined WITH_PSEUC
1133 if (isbigc_string(p))
1134 return read_bigc_string(p);
1135 #endif /* HAVE_MPC */
1137 #if defined HAVE_MPFR && defined WITH_MPFR
1138 if (isfloat_string(p) && b == 10) {
1139 if (!(default_real_precision) || Vread_real_as != Qbigfr)
1140 return make_float(str_to_fpfloat((const char*)p));
1142 return read_bigfr_string(p);
1144 #elif defined HAVE_MPF && defined WITH_GMP
1145 if (isfloat_string(p) && b == 10) {
1146 if (!(default_real_precision) || Vread_real_as != Qbigf)
1147 return make_float(str_to_fpfloat((const char*)p));
1149 return read_bigf_string(p);
1151 #elif defined HAVE_FPFLOAT
1152 if (isfloat_string(p) && b == 10)
1153 return make_float(str_to_fpfloat(p));
1154 #endif /* HAVE_MPFR || HAVE_MPFR || HAVE_FPFLOAT */
1156 if (ase_resc_elm_pred_f && ase_resc_elm_f &&
1157 ase_resc_elm_pred_f(p))
1158 return ase_resc_elm_f(p);
1160 #if defined HAVE_QUATERN && defined WITH_QUATERN
1161 if (isquatern_string(p))
1162 return read_quatern_string(p);
1163 #endif /* HAVE_QUATERN */
1165 #if defined HAVE_MPQ && defined WITH_GMP
1166 if (strchr (p, '/') != NULL) {
1168 return read_bigq_string(p);
1170 /* do we even need fractions in different bases? */
1181 while ((*end >= '0' && *end <= '9') ||
1182 (b > 10 && *end >= 'a' && *end <= 'a' + b - 11) ||
1183 (b > 10 && *end >= 'A' && *end <= 'A' + b - 11))
1189 while ((*end >= '0' && *end <= '9') ||
1190 (b > 10 && *end >= 'a' &&
1191 *end <= 'a' + b - 11) ||
1192 (b > 10 && *end >= 'A' &&
1193 *end <= 'A' + b - 11))
1201 bigq_set_string(bq, (const char *) p, b);
1203 bigq_canonicalize(bq);
1205 result = make_bigq_bq(bq);
1211 #endif /* HAVE_MPQ */
1213 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1223 while ((*end >= '0' && *end <= '9') ||
1224 (b > 10 && *end >= 'a' && *end <= 'a' + b - 11) ||
1225 (b > 10 && *end >= 'A' && *end <= 'A' + b - 11))
1230 retval = make_int(0);
1234 bigz_set_string(bz, (const char *)p, b);
1235 retval = ent_mpz_downgrade_maybe(bz);
1242 #else /* !HAVE_MPZ */
1245 /* Use the system-provided functions for base 10. */
1246 #if SIZEOF_EMACS_INT == SIZEOF_INT
1247 return make_int(atoi(p));
1248 #elif SIZEOF_EMACS_INT == SIZEOF_LONG
1249 return make_int(atol(p));
1250 #elif SIZEOF_EMACS_INT == SIZEOF_LONG_LONG_INT
1251 return make_int(atoll(p));
1260 } else if (*p == '+')
1263 int digit = digit_to_number(*p++, b);
1268 return make_int(negative * v);
1270 #endif /* HAVE_MPZ */
1274 DEFUN("logand", Flogand, 0, MANY, 0, /*
1275 Return bitwise-and of all the arguments.
1276 Arguments may be integers, or markers or characters converted to integers.
1278 (int nargs, Lisp_Object * args))
1280 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1282 Lisp_Object result, other;
1283 ase_object_type_t nt1, nt2;
1286 return make_int(~0);
1289 if (!(INTEGERP(result) || CHARP(result) || MARKERP(result)))
1290 result = wrong_type_argument(Qintegerp, result);
1293 return make_int(ent_int(result));
1295 for (i = 1; i < nargs; i++) {
1297 if (!(INTEGERP(other) || CHARP(other) || MARKERP(other)))
1298 other = wrong_type_argument(Qintegerp, other);
1300 nt1 = ase_optable_index(result);
1301 nt2 = ase_optable_index(other);
1303 if (nt1 == INT_T && nt2 == INT_T) {
1304 result = make_int(ent_int(result) & ent_int(other));
1305 } else if (nt1 == INT_T && nt2 == BIGZ_T) {
1306 bigz_set_long(ent_scratch_bigz, ent_int(result));
1307 bigz_and(ent_scratch_bigz,
1310 result = ent_mpz_downgrade_maybe(ent_scratch_bigz);
1311 } else if (nt1 == BIGZ_T && nt2 == INT_T) {
1312 bigz_set_long(ent_scratch_bigz, ent_int(other));
1313 bigz_and(ent_scratch_bigz,
1316 result = ent_mpz_downgrade_maybe(ent_scratch_bigz);
1317 } else if (nt1 == BIGZ_T && nt2 == BIGZ_T) {
1318 bigz_and(ent_scratch_bigz,
1321 result = ent_mpz_downgrade_maybe(ent_scratch_bigz);
1326 #else /* !HAVE_MPZ */
1327 EMACS_INT bits = ~0;
1328 Lisp_Object *args_end = args + nargs;
1330 while (args < args_end)
1331 bits &= integer_char_or_marker_to_int(*args++);
1333 return make_int(bits);
1334 #endif /* HAVE_MPZ */
1337 DEFUN("logior", Flogior, 0, MANY, 0, /*
1338 Return bitwise-or of all the arguments.
1339 Arguments may be integers, or markers or characters converted to integers.
1341 (int nargs, Lisp_Object * args))
1343 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1345 Lisp_Object result, other;
1346 ase_object_type_t nt1, nt2;
1352 if (!(INTEGERP(result) || CHARP(result) || MARKERP(result)))
1353 result = wrong_type_argument(Qintegerp, result);
1356 return make_int(ent_int(result));
1358 for (i = 1; i < nargs; i++) {
1360 if (!(INTEGERP(other) || CHARP(other) || MARKERP(other)))
1361 other = wrong_type_argument(Qintegerp, other);
1363 nt1 = ase_optable_index(result);
1364 nt2 = ase_optable_index(other);
1366 if (nt1 == INT_T && nt2 == INT_T) {
1367 result = make_int(ent_int(result) | ent_int(other));
1368 } else if (nt1 == INT_T && nt2 == BIGZ_T) {
1369 bigz_set_long(ent_scratch_bigz, ent_int(result));
1370 bigz_ior(ent_scratch_bigz,
1373 result = ent_mpz_downgrade_maybe(ent_scratch_bigz);
1374 } else if (nt1 == BIGZ_T && nt2 == INT_T) {
1375 bigz_set_long(ent_scratch_bigz, ent_int(other));
1376 bigz_ior(ent_scratch_bigz,
1379 result = ent_mpz_downgrade_maybe(ent_scratch_bigz);
1380 } else if (nt1 == BIGZ_T && nt2 == BIGZ_T) {
1381 bigz_ior(ent_scratch_bigz,
1384 result = ent_mpz_downgrade_maybe(ent_scratch_bigz);
1389 #else /* !HAVE_MPZ */
1392 Lisp_Object *args_end = args + nargs;
1394 while (args < args_end)
1395 bits |= integer_char_or_marker_to_int(*args++);
1397 return make_int(bits);
1398 #endif /* HAVE_MPZ */
1401 DEFUN("logxor", Flogxor, 0, MANY, 0, /*
1402 Return bitwise-exclusive-or of all the arguments.
1403 Arguments may be integers, or markers or characters converted to integers.
1405 (int nargs, Lisp_Object * args))
1407 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1409 Lisp_Object result, other;
1410 ase_object_type_t nt1, nt2;
1416 if (!(INTEGERP(result) || CHARP(result) || MARKERP(result)))
1417 result = wrong_type_argument(Qintegerp, result);
1420 return make_int(ent_int(result));
1422 for (i = 1; i < nargs; i++) {
1424 if (!(INTEGERP(other) || CHARP(other) || MARKERP(other)))
1425 other = wrong_type_argument(Qintegerp, other);
1427 nt1 = ase_optable_index(result);
1428 nt2 = ase_optable_index(other);
1430 if (nt1 == INT_T && nt2 == INT_T) {
1431 result = make_int(ent_int(result) ^ ent_int(other));
1432 } else if (nt1 == INT_T && nt2 == BIGZ_T) {
1433 bigz_set_long(ent_scratch_bigz, ent_int(result));
1434 bigz_xor(ent_scratch_bigz,
1437 result = ent_mpz_downgrade_maybe(ent_scratch_bigz);
1438 } else if (nt1 == BIGZ_T && nt2 == INT_T) {
1439 bigz_set_long(ent_scratch_bigz, ent_int(other));
1440 bigz_xor(ent_scratch_bigz,
1443 result = ent_mpz_downgrade_maybe(ent_scratch_bigz);
1444 } else if (nt1 == BIGZ_T && nt2 == BIGZ_T) {
1445 bigz_xor(ent_scratch_bigz,
1448 result = ent_mpz_downgrade_maybe(ent_scratch_bigz);
1453 #else /* !HAVE_MPZ */
1456 Lisp_Object *args_end = args + nargs;
1458 while (args < args_end)
1459 bits ^= integer_char_or_marker_to_int(*args++);
1461 return make_int(bits);
1462 #endif /* HAVE_MPZ */
1465 DEFUN("lognot", Flognot, 1, 1, 0, /*
1466 Return the bitwise complement of NUMBER.
1467 NUMBER may be an integer, marker or character converted to integer.
1471 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1472 if (BIGZP(number)) {
1478 bigz_not(bz, XBIGZ_DATA(number));
1479 result = make_bigz_bz(bz);
1484 return make_int(~integer_char_or_marker_to_int(number));
1486 #else /* HAVE_MPZ */
1487 return make_int(~integer_char_or_marker_to_int(number));
1488 #endif /* HAVE_MPZ */
1491 /* Note, ANSI *requires* the presence of the fmod() library routine.
1492 If your system doesn't have it, complain to your vendor, because
1496 double fmod(double f1, double f2)
1500 return f1 - f2 * floor(f1 / f2);
1502 #endif /* ! HAVE_FMOD */
1504 DEFUN("ash", Fash, 2, 2, 0, /*
1505 Return VALUE with its bits shifted left by COUNT.
1506 If COUNT is negative, shifting is actually to the right.
1507 In this case, the sign bit is duplicated.
1511 CHECK_INT_COERCE_CHAR(value);
1512 CONCHECK_INT(count);
1514 return make_int(XINT(count) > 0 ?
1515 XINT(value) << XINT(count) :
1516 XINT(value) >> -XINT(count));
1519 DEFUN("lsh", Flsh, 2, 2, 0, /*
1520 Return VALUE with its bits shifted left by COUNT.
1521 If COUNT is negative, shifting is actually to the right.
1522 In this case, zeros are shifted in on the left.
1526 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1530 value = Fcoerce_number(value, Qinteger, Qnil);
1531 CONCHECK_INT(count);
1533 switch (ase_optable_index(value)) {
1535 if (XREALINT(count) <= 0)
1536 return make_int(XREALINT(value) >> -XREALINT(count));
1537 /* Use bignums to avoid overflow */
1538 bigz_set_long(ent_scratch_bigz, XREALINT(value));
1539 bigz_lshift(ent_scratch_bigz,
1540 ent_scratch_bigz, XREALINT(count));
1542 result = ent_mpz_downgrade_maybe(ent_scratch_bigz);
1545 if (XREALINT(count) <= 0) {
1546 bigz_rshift(ent_scratch_bigz,
1550 bigz_lshift(ent_scratch_bigz,
1554 result = ent_mpz_downgrade_maybe(ent_scratch_bigz);
1557 if (COMPARABLE_INDEF_P(value))
1559 else if (COMPARABLE_INDEF_P(count) &&
1560 XINDEF_DATA(count) == POS_INFINITY)
1561 result = make_indef(POS_INFINITY);
1562 else if (COMPARABLE_INDEF_P(count) &&
1563 XINDEF_DATA(count) == NEG_INFINITY)
1572 #else /* HAVE_MPZ */
1573 CHECK_INT_COERCE_CHAR(value);
1574 CONCHECK_INT(count);
1576 return make_int(XINT(count) > 0 ?
1577 XUINT(value) << XINT(count) :
1578 XUINT(value) >> -XINT(count));
1579 #endif /* HAVE_MPZ */
1582 /* Number theoretic functions */
1584 #if defined WITH_GMP && defined HAVE_MPZ
1586 /* why do we put this cruft here, actually? Is not it better to have a separate
1587 * number-fns.c or the like?
1590 DEFUN("primep", Fprimep, 1, 2, 0, /*
1591 Return `nil' if NUMBER is known to be composite, return `t' if
1592 NUMBER is definitely prime and return 'probably-prime if
1593 NUMBER seems to be prime but it is not certain.
1595 If optional argument CERTAINTY-THRESHOLD is non-nil, it should be a
1596 natural number to indicate how many probabilistic primality tests must
1597 be passed in order to have certainty about the primality of NUMBER.
1600 (number, certainty_threshold))
1602 Lisp_Object bznumber;
1608 bznumber = Fcoerce_number(number, Qbigz, Qnil);
1609 if (NILP(certainty_threshold))
1610 result = mpz_probab_prime_p(XBIGZ_DATA(bznumber), 8);
1611 else if (NATNUMP(certainty_threshold))
1612 result = mpz_probab_prime_p(XBIGZ_DATA(bznumber),
1613 XINT(certainty_threshold));
1615 result = wrong_type_argument(Qnatnump, certainty_threshold);
1619 else if (result == 1)
1620 return intern("probably-prime");
1621 else if (result == 2)
1624 return intern("unknown-test-result");
1627 DEFUN("next-prime", Fnext_prime, 1, 1, 0, /*
1628 Return the next prime number greater than NUMBER.
1632 Lisp_Object bznumber;
1634 if (INDEFP(number)) {
1638 bznumber = Fcoerce_number(number, Qbigz, Qnil);
1639 mpz_nextprime(ent_scratch_bigz, XBIGZ_DATA(bznumber));
1640 return ent_mpz_downgrade_maybe(ent_scratch_bigz);
1644 DEFUN("factorial", Ffactorial, 1, 1, 0, /*
1645 Return the factorial of NUMBER.
1652 if (INDEFP(number) &&
1653 XINDEF_DATA(number) == POS_INFINITY)
1656 if (!INTP(number)) {
1657 number = wrong_type_argument(Qintegerp, number);
1660 if (!NATNUMP(number)) {
1661 number = wrong_type_argument(Qnatnump, number);
1667 mpz_fac_ui(bz, XUINT(number));
1668 result = make_bigz_bz(bz);
1674 DEFUN("binomial-coefficient", Fbinomial_coefficient, 2, 2, 0, /*
1675 Return the binomial coefficient, N over K.
1686 if (NILP(Fnonnegativep(k)))
1687 return wrong_type_argument(Qnonnegativep, k);
1691 kui = bigz_to_ulong(XBIGZ_DATA(k));
1693 return wrong_type_argument(Qintegerp, k);
1695 n = Fcoerce_number(n, Qbigz, Qnil);
1698 mpz_bin_ui(bz, XBIGZ_DATA(n), kui);
1699 result = make_bigz_bz(bz);
1705 DEFUN("remove-factor", Fremove_factor, 2, 2, 0, /*
1706 Remove all occurences of FACTOR in NUMBER and return a cons cell
1707 with NUMBER divided by a maximal power of FACTOR in the car and
1708 the exponent in the cdr.
1709 FACTOR must be non-negative and greater than 1.
1713 Lisp_Object bznumber, bzfactor;
1716 unsigned long occur;
1718 if (INDEFP(factor) && INDEFP(number)) {
1719 if (XINDEF_DATA(factor) == POS_INFINITY)
1720 return Fcons(factor, factor);
1722 return wrong_type_argument(Qnonnegativep, factor);
1724 if (INDEFP(factor)) {
1725 if (XINDEF_DATA(factor) == POS_INFINITY)
1726 return Fcons(number, Qzero);
1728 return wrong_type_argument(Qnonnegativep, factor);
1730 if (INDEFP(number)) {
1731 if (INFINITYP(number))
1732 return Fcons(number, make_indef(POS_INFINITY));
1734 return wrong_type_argument(Qnumberp, number);
1739 bznumber = Fcoerce_number(number, Qbigz, Qnil);
1740 bzfactor = Fcoerce_number(factor, Qbigz, Qnil);
1742 bigz_set_long(bz, 1L);
1743 if (bigz_eql(XBIGZ_DATA(bzfactor), bz)) {
1744 /* factor is one, which is always in a prime decomposition */
1746 return Fcons(bznumber, make_indef(POS_INFINITY));
1748 bigz_set_long(bz, -1L);
1749 if (bigz_eql(XBIGZ_DATA(bzfactor), bz)) {
1750 /* factor is -1, which is always in a prime decomposition
1751 * (it is a unit), but as such it occurs only pairwise, that's
1752 * why we return 0 as exponent here
1755 return Fcons(bznumber, Qzero);
1757 bigz_set_long(bz, 0L);
1758 if (bigz_eql(XBIGZ_DATA(bzfactor), bz)) {
1759 /* factor is zero, which is never in a prime decomposition */
1761 return Fcons(bznumber, Qzero);
1763 if (bigz_lt(XBIGZ_DATA(bzfactor), bz)) {
1764 /* factor is negative, which is bad if number is positive */
1765 bigz_neg(XBIGZ_DATA(bzfactor), XBIGZ_DATA(bzfactor));
1766 occur = mpz_remove(bz, XBIGZ_DATA(bznumber),
1767 XBIGZ_DATA(bzfactor));
1768 /* negate the result, iff the exponent is odd */
1769 if ((occur % 2) != 0)
1771 result = make_bigz_bz(bz);
1773 occur = mpz_remove(bz,
1774 XBIGZ_DATA(bznumber),
1775 XBIGZ_DATA(bzfactor));
1776 result = make_bigz_bz(bz);
1780 return Fcons(result, make_integer((signed long)occur));
1783 DEFUN("fibonacci", Ffibonacci, 1, 1, 0, /*
1784 Return the NUMBERth Fibonacci number.
1785 To compute both, the NUMBERth and (NUMBER-1)th Fibonacci
1786 number use `fibonacci2' instead.
1794 CHECK_INTEGER(number);
1796 if (NILP(Fnonnegativep(number)))
1797 return wrong_type_argument(Qnonnegativep, number);
1798 else if (INTP(number))
1800 else if (BIGZP(number))
1801 n = bigz_to_ulong(XBIGZ_DATA(number));
1803 return wrong_type_argument(Qintegerp, number);
1807 result = make_bigz_bz(bz);
1813 DEFUN("fibonacci2", Ffibonacci2, 1, 1, 0, /*
1814 Return a cons with the NUMBERth and (NUMBER-1)th Fibonacci number.
1815 To compute a series of Fibonacci numbers starting at index
1816 NUMBER, use this function and recursively compute the rest.
1824 CHECK_INTEGER(number);
1826 if (NILP(Fnonnegativep(number)))
1827 return wrong_type_argument(Qnonnegativep, number);
1828 else if (INTP(number))
1830 else if (BIGZP(number))
1831 n = bigz_to_ulong(XBIGZ_DATA(number));
1833 return wrong_type_argument(Qintegerp, number);
1837 mpz_fib2_ui(bzn, bznsub1, n);
1838 result = Fcons(make_bigz_bz(bzn),
1839 make_bigz_bz(bznsub1));
1846 DEFUN("lucas", Flucas, 1, 1, 0, /*
1847 Return the NUMBERth Lucas number.
1848 To compute both, the NUMBERth and (NUMBER-1)th Lucas
1849 number use `lucas2' instead.
1857 CHECK_INTEGER(number);
1859 if (NILP(Fnonnegativep(number)))
1860 return wrong_type_argument(Qnonnegativep, number);
1861 else if (INTP(number))
1863 else if (BIGZP(number))
1864 n = bigz_to_ulong(XBIGZ_DATA(number));
1866 return wrong_type_argument(Qintegerp, number);
1869 mpz_lucnum_ui(bz, n);
1870 result = make_bigz_bz(bz);
1876 DEFUN("lucas2", Flucas2, 1, 1, 0, /*
1877 Return a cons with the NUMBERth and (NUMBER-1)th Lucas number.
1878 To compute a series of Lucas numbers starting at index
1879 NUMBER, use this function and recursively compute the rest.
1887 CHECK_INTEGER(number);
1889 if (NILP(Fnonnegativep(number)))
1890 return wrong_type_argument(Qnonnegativep, number);
1891 else if (INTP(number))
1893 else if (BIGZP(number))
1894 n = bigz_to_ulong(XBIGZ_DATA(number));
1896 return wrong_type_argument(Qintegerp, number);
1900 mpz_lucnum2_ui(bzn, bznsub1, n);
1901 result = Fcons(make_bigz_bz(bzn),
1902 make_bigz_bz(bznsub1));
1909 DEFUN("divisiblep", Fdivisiblep, 2, 2, 0, /*
1910 Return t if NUMBER is divisible by D, nil otherwise.
1914 CHECK_INTEGER(number);
1917 number = Fcoerce_number(number, Qbigz, Qnil);
1919 return mpz_divisible_ui_p(XBIGZ_DATA(number), XINT(d))
1922 return mpz_divisible_p(XBIGZ_DATA(number), XBIGZ_DATA(d))
1925 return wrong_type_argument(Qintegerp, d);
1928 DEFUN("congruentp", Fcongruentp, 3, 3, 0, /*
1929 Return t if NUMBER is congruent to C modulo M, nil otherwise.
1933 CHECK_INTEGER(number);
1937 number = Fcoerce_number(number, Qbigz, Qnil);
1938 if (INTP(c) && INTP(m))
1939 return mpz_congruent_ui_p(XBIGZ_DATA(number), XINT(c), XINT(m))
1942 c = Fcoerce_number(c, Qbigz, Qnil);
1943 m = Fcoerce_number(m, Qbigz, Qnil);
1944 return mpz_congruent_p(XBIGZ_DATA(number),
1945 XBIGZ_DATA(c), XBIGZ_DATA(m))
1950 DEFUN("perfect-power-p", Fperfect_power_p, 1, 1, 0, /*
1951 Return t if NUMBER is a perfect power, nil otherwise.
1952 An integer NUMBER is said to be a perfect power if there
1953 exist integers, a and b, such that a^b = NUMBER.
1957 CHECK_INTEGER(number);
1959 number = Fcoerce_number(number, Qbigz, Qnil);
1961 return mpz_perfect_power_p(XBIGZ_DATA(number)) ? Qt : Qnil;
1964 DEFUN("perfect-square-p", Fperfect_square_p, 1, 1, 0, /*
1965 Return t if NUMBER is a perfect square, nil otherwise.
1966 An integer NUMBER is said to be a perfect square if there
1967 exists an integer b such that b^2 = NUMBER.
1971 CHECK_INTEGER(number);
1973 number = Fcoerce_number(number, Qbigz, Qnil);
1975 return mpz_perfect_square_p(XBIGZ_DATA(number)) ? Qt : Qnil;
1978 DEFUN("integral-sqrt", Fintegral_sqrt, 1, 1, 0, /*
1979 Return a cons with the integral square root of NUMBER
1980 in the car and the remainder in the cdr.
1981 An integral square root is a number b and a remainder c
1982 such that b*b + c = NUMBER.
1989 CHECK_INTEGER(number);
1991 number = Fcoerce_number(number, Qbigz, Qnil);
1995 mpz_sqrtrem(bzsqrt, bzrem, XBIGZ_DATA(number));
1997 result = Fcons(make_bigz_bz(bzsqrt), make_bigz_bz(bzrem));
2004 #endif /* WITH_GMP && HAVE_MPZ */
2006 DEFUN("zero-divisor-p", Fzero_divisor_p, 1, 1, 0, /*
2007 Return t if NUMBER is a zero-divisor, nil otherwise.
2008 That is, if there exists another non-zero number B, such that
2015 CHECK_NUMBER(number);
2017 switch (ase_optable_index(number)) {
2024 #if defined WITH_ECM && defined HAVE_ECM && \
2025 defined HAVE_MPZ && defined WITH_GMP
2026 DEFUN("factorise", Ffactorise, 1, 3, 0, /*
2027 Return the factorisation of NUMBER.
2028 If optional arument B1 is non-nil, it should be a float used as
2030 Second optional argument method can be 'ecm, 'p-1 'p+1.
2032 (number, b1, method))
2040 Lisp_Object result = Qnil;
2044 bzn = Fcoerce_number(number, Qbigz, Qnil);
2047 bigz_init(bznumber);
2048 bigz_set(bznumber, XBIGZ_DATA(bzn));
2053 sb1 = extract_float(b1);
2057 } else if (method == intern("p-1")) {
2058 p->method = ECM_PM1;
2059 } else if (method == intern("p+1")) {
2060 p->method = ECM_PP1;
2062 p->method = ECM_ECM;
2066 while (status > 0) {
2067 status = ecm_factor(bz, bznumber, sb1, p);
2069 factor_l = bigz_to_long(bz);
2070 if (factor_l == 1 || factor_l == -1)
2072 if (status > 0 && factor_l != 0) {
2073 expt = mpz_remove(bznumber, bznumber, bz);
2074 result = Fcons(Fcons(make_bigz_bz(bz),
2081 bigz_fini(bznumber);
2086 #endif /* WITH_ECM && HAVE_ECM */
2088 #if defined(WITH_GMP) && (defined(HAVE_MPZ) || defined(HAVE_MPQ))
2089 DEFUN("gcd", Fgcd, 0, MANY, 0, /*
2090 Return the greatest common divisor of the arguments.
2092 (int nargs, Lisp_Object *args))
2098 else if (nargs == 1)
2110 switch (ase_optable_index(bzn)) {
2112 bzn = Fcoerce_number(bzn, Qbigz, Qnil);
2113 bigz_set(bz, XBIGZ_DATA(bzn));
2114 bigz_set_long(bzden, 1L);
2117 bigz_set(bz, XBIGZ_DATA(bzn));
2118 bigz_set_long(bzden, 1L);
2121 bigz_set(bz, XBIGQ_NUMERATOR(bzn));
2122 bigz_set(bzden, XBIGQ_DENOMINATOR(bzn));
2125 /* no gcd defined for the rest */
2134 for (i = 1; i < nargs; i++) {
2137 switch (ase_optable_index(bzn)) {
2139 bzn = Fcoerce_number(bzn, Qbigz, Qnil);
2140 bigz_set(bznum, XBIGZ_DATA(bzn));
2143 bigz_set(bznum, XBIGZ_DATA(bzn));
2146 bigz_mul(bzden, bzden, XBIGQ_DENOMINATOR(bzn));
2147 bigz_set(bznum, XBIGQ_NUMERATOR(bzn));
2150 /* no gcd defined for the rest */
2159 bigz_gcd(bz, bz, bznum);
2161 if (bigz_fits_long_p(bzden) &&
2162 bigz_to_long(bzden) == 1L) {
2163 bzn = make_bigz_bz(bz);
2165 bzn = make_bigq_bz(bz, bzden);
2176 DEFUN("xgcd", Fxgcd, 0, MANY, 0, /*
2177 Return the extended gcd of the arguments.
2178 The result is a list of integers, where the car is the actual gcd
2179 and the cdr consists of coefficients, s1, ..., sn, such that
2180 s1*arg1 + s2*arg2 + ... + sn*argn = gcd.
2182 (int nargs, Lisp_Object *args))
2187 return list1(Qzero);
2188 else if (nargs == 1)
2189 return list2(args[0], make_int(1L));
2197 Lisp_Object *qargs = alloca_array(Lisp_Object, nargs+1);
2205 switch (ase_optable_index(bzn)) {
2207 bzn = Fcoerce_number(bzn, Qbigz, Qnil);
2208 bigz_set(bz, XBIGZ_DATA(bzn));
2209 bigz_set_long(bzden, 1L);
2212 bigz_set(bz, XBIGZ_DATA(bzn));
2213 bigz_set_long(bzden, 1L);
2216 bigz_set(bz, XBIGQ_NUMERATOR(bzn));
2217 bigz_set(bzden, XBIGQ_DENOMINATOR(bzn));
2220 /* no gcd defined for the rest */
2227 return list1(Qzero);
2231 qargs[1] = make_bigz(1L);
2232 for (i = 1; i < nargs; i++) {
2235 switch (ase_optable_index(bzn)) {
2237 bzn = Fcoerce_number(bzn, Qbigz, Qnil);
2238 bigz_set(bznum, XBIGZ_DATA(bzn));
2241 bigz_set(bznum, XBIGZ_DATA(bzn));
2243 /* multiply across fractions */
2245 bigz_set(bznum, XBIGQ_NUMERATOR(bzn));
2246 bigz_mul(bznum, bznum, bzden);
2247 bigz_mul(bzden, bzden, XBIGQ_DENOMINATOR(bzn));
2248 bigz_mul(bz, bz, XBIGQ_DENOMINATOR(bzn));
2251 /* no gcd defined for the rest */
2258 return list1(Qzero);
2262 mpz_gcdext(bz, bs, bt, bz, bznum);
2263 for (j = i; j > 0; j--) {
2264 bigz_mul(XBIGZ_DATA(qargs[j]),
2265 XBIGZ_DATA(qargs[j]),
2268 qargs[i+1] = make_bigz_bz(bt);
2270 if (bigz_fits_long_p(bzden) &&
2271 bigz_to_long(bzden) == 1L) {
2272 qargs[0] = make_bigz_bz(bz);
2274 qargs[0] = make_bigq_bz(bz, bzden);
2281 return Flist(nargs+1, qargs);
2287 DEFUN("lcm", Flcm, 0, MANY, 0, /*
2288 Return the least common multiple of the arguments.
2290 (int nargs, Lisp_Object *args))
2296 else if (nargs == 1)
2308 switch (ase_optable_index(bzn)) {
2310 bzn = Fcoerce_number(bzn, Qbigz, Qnil);
2311 bigz_set(bz, XBIGZ_DATA(bzn));
2312 bigz_set_long(bzden, 1L);
2315 bigz_set(bz, XBIGZ_DATA(bzn));
2316 bigz_set_long(bzden, 1L);
2319 bigz_set(bz, XBIGQ_NUMERATOR(bzn));
2320 bigz_set(bzden, XBIGQ_DENOMINATOR(bzn));
2323 /* no lcm defined for the rest */
2332 for (i = 1; i < nargs; i++) {
2335 switch (ase_optable_index(bzn)) {
2337 bzn = Fcoerce_number(bzn, Qbigz, Qnil);
2338 bigz_set(bznum, XBIGZ_DATA(bzn));
2341 bigz_set(bznum, XBIGZ_DATA(bzn));
2343 /* multiply across fractions */
2345 bigz_set(bznum, XBIGQ_NUMERATOR(bzn));
2346 bigz_mul(bznum, bznum, bzden);
2347 bigz_mul(bzden, bzden, XBIGQ_DENOMINATOR(bzn));
2348 bigz_mul(bz, bz, XBIGQ_DENOMINATOR(bzn));
2351 /* no gcd defined for the rest */
2359 bigz_lcm(bz, bz, bznum);
2361 if (bigz_fits_long_p(bzden) &&
2362 bigz_to_long(bzden) == 1L) {
2363 bzn = make_bigz_bz(bz);
2365 bzn = make_bigq_bz(bz, bzden);
2375 #endif /* WITH_GMP && (HAVE_MPZ || HAVE_MPQ) */
2378 /************************************************************************/
2380 /************************************************************************/
2382 /* A weak list is like a normal list except that elements automatically
2383 disappear when no longer in use, i.e. when no longer GC-protected.
2384 The basic idea is that we don't mark the elements during GC, but
2385 wait for them to be marked elsewhere. If they're not marked, we
2386 remove them. This is analogous to weak hash tables; see the explanation
2387 there for more info. */
2389 static Lisp_Object Vall_weak_lists; /* Gemarke es nicht!!! */
2391 static Lisp_Object encode_weak_list_type(enum weak_list_type type);
2393 static Lisp_Object mark_weak_list(Lisp_Object obj)
2395 return Qnil; /* nichts ist gemarkt */
2396 /* avoid some warning */
2397 return (obj == Qnil);
2401 print_weak_list(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
2404 error("printing unreadable object #<weak-list>");
2406 write_c_string("#<weak-list ", printcharfun);
2407 print_internal(encode_weak_list_type(XWEAK_LIST(obj)->type),
2409 write_c_string(" ", printcharfun);
2410 print_internal(XWEAK_LIST(obj)->list, printcharfun, escapeflag);
2411 write_c_string(">", printcharfun);
2414 static int weak_list_equal(Lisp_Object obj1, Lisp_Object obj2, int depth)
2416 struct weak_list *w1 = XWEAK_LIST(obj1);
2417 struct weak_list *w2 = XWEAK_LIST(obj2);
2419 return ((w1->type == w2->type) &&
2420 internal_equal(w1->list, w2->list, depth + 1));
2423 static unsigned long weak_list_hash(Lisp_Object obj, int depth)
2425 struct weak_list *w = XWEAK_LIST(obj);
2427 return HASH2((unsigned long)w->type, internal_hash(w->list, depth + 1));
2430 Lisp_Object make_weak_list(enum weak_list_type type)
2433 struct weak_list *wl =
2434 alloc_lcrecord_type(struct weak_list, &lrecord_weak_list);
2438 XSETWEAK_LIST(result, wl);
2439 wl->next_weak = Vall_weak_lists;
2440 Vall_weak_lists = result;
2444 static const struct lrecord_description weak_list_description[] = {
2445 {XD_LISP_OBJECT, offsetof(struct weak_list, list)},
2446 {XD_LO_LINK, offsetof(struct weak_list, next_weak)},
2450 DEFINE_LRECORD_IMPLEMENTATION("weak-list", weak_list,
2451 mark_weak_list, print_weak_list,
2452 0, weak_list_equal, weak_list_hash,
2453 weak_list_description, struct weak_list);
2455 -- we do not mark the list elements (either the elements themselves
2456 or the cons cells that hold them) in the normal marking phase.
2457 -- at the end of marking, we go through all weak lists that are
2458 marked, and mark the cons cells that hold all marked
2459 objects, and possibly parts of the objects themselves.
2460 (See alloc.c, "after-mark".)
2461 -- after that, we prune away all the cons cells that are not marked.
2463 WARNING WARNING WARNING WARNING WARNING:
2465 The code in the following two functions is *unbelievably* tricky.
2466 Don't mess with it. You'll be sorry.
2468 Linked lists just majorly suck, d'ya know?
2471 int finish_marking_weak_lists(void)
2476 for (rest = Vall_weak_lists;
2477 !NILP(rest); rest = XWEAK_LIST(rest)->next_weak) {
2479 enum weak_list_type type = XWEAK_LIST(rest)->type;
2481 if (!marked_p(rest))
2482 /* The weak list is probably garbage. Ignore it. */
2485 for (rest2 = XWEAK_LIST(rest)->list;
2486 /* We need to be trickier since we're inside of GC;
2487 use CONSP instead of !NILP in case of user-visible
2489 CONSP(rest2); rest2 = XCDR(rest2)) {
2491 /* If the element is "marked" (meaning depends on the type
2492 of weak list), we need to mark the cons containing the
2493 element, and maybe the element itself (if only some part
2494 was already marked). */
2495 int need_to_mark_cons = 0;
2496 int need_to_mark_elem = 0;
2498 /* If a cons is already marked, then its car is already marked
2499 (either because of an external pointer or because of
2500 a previous call to this function), and likewise for all
2501 the rest of the elements in the list, so we can stop now. */
2502 if (marked_p(rest2))
2508 case WEAK_LIST_SIMPLE:
2510 need_to_mark_cons = 1;
2513 case WEAK_LIST_ASSOC:
2515 /* just leave bogus elements there */
2516 need_to_mark_cons = 1;
2517 need_to_mark_elem = 1;
2518 } else if (marked_p(XCAR(elem)) &&
2519 marked_p(XCDR(elem))) {
2520 need_to_mark_cons = 1;
2521 /* We still need to mark elem, because it's
2522 probably not marked. */
2523 need_to_mark_elem = 1;
2527 case WEAK_LIST_KEY_ASSOC:
2529 /* just leave bogus elements there */
2530 need_to_mark_cons = 1;
2531 need_to_mark_elem = 1;
2532 } else if (marked_p(XCAR(elem))) {
2533 need_to_mark_cons = 1;
2534 /* We still need to mark elem and XCDR (elem);
2535 marking elem does both */
2536 need_to_mark_elem = 1;
2540 case WEAK_LIST_VALUE_ASSOC:
2542 /* just leave bogus elements there */
2543 need_to_mark_cons = 1;
2544 need_to_mark_elem = 1;
2545 } else if (marked_p(XCDR(elem))) {
2546 need_to_mark_cons = 1;
2547 /* We still need to mark elem and XCAR (elem);
2548 marking elem does both */
2549 need_to_mark_elem = 1;
2553 case WEAK_LIST_FULL_ASSOC:
2555 /* just leave bogus elements there */
2556 need_to_mark_cons = 1;
2557 need_to_mark_elem = 1;
2558 } else if (marked_p(XCAR(elem)) ||
2559 marked_p(XCDR(elem))) {
2560 need_to_mark_cons = 1;
2561 /* We still need to mark elem and XCAR (elem);
2562 marking elem does both */
2563 need_to_mark_elem = 1;
2571 if (need_to_mark_elem && !marked_p(elem)) {
2576 /* We also need to mark the cons that holds the elem or
2577 assoc-pair. We do *not* want to call (mark_object) here
2578 because that will mark the entire list; we just want to
2579 mark the cons itself.
2581 if (need_to_mark_cons) {
2582 Lisp_Cons *c = XCONS(rest2);
2583 if (!CONS_MARKED_P(c)) {
2590 /* In case of imperfect list, need to mark the final cons
2591 because we're not removing it */
2592 if (!NILP(rest2) && !marked_p(rest2)) {
2601 void prune_weak_lists(void)
2603 Lisp_Object rest, prev = Qnil;
2605 for (rest = Vall_weak_lists;
2606 !NILP(rest); rest = XWEAK_LIST(rest)->next_weak) {
2607 if (!(marked_p(rest))) {
2608 /* This weak list itself is garbage. Remove it from the list. */
2610 Vall_weak_lists = XWEAK_LIST(rest)->next_weak;
2612 XWEAK_LIST(prev)->next_weak =
2613 XWEAK_LIST(rest)->next_weak;
2615 Lisp_Object rest2, prev2 = Qnil;
2616 Lisp_Object tortoise;
2617 int go_tortoise = 0;
2619 for (rest2 = XWEAK_LIST(rest)->list, tortoise = rest2;
2620 /* We need to be trickier since we're inside of GC;
2621 use CONSP instead of !NILP in case of user-visible
2624 /* It suffices to check the cons for marking,
2625 regardless of the type of weak list:
2627 -- if the cons is pointed to somewhere else,
2628 then it should stay around and will be marked.
2629 -- otherwise, if it should stay around, it will
2630 have been marked in finish_marking_weak_lists().
2631 -- otherwise, it's not marked and should disappear.
2633 if (!marked_p(rest2)) {
2636 XWEAK_LIST(rest)->list =
2639 XCDR(prev2) = XCDR(rest2);
2640 rest2 = XCDR(rest2);
2641 /* Ouch. Circularity checking is even trickier
2642 than I thought. When we cut out a link
2643 like this, we can't advance the turtle or
2644 it'll catch up to us. Imagine that we're
2645 standing on floor tiles and moving forward --
2646 what we just did here is as if the floor
2647 tile under us just disappeared and all the
2648 ones ahead of us slid one tile towards us.
2649 In other words, we didn't move at all;
2650 if the tortoise was one step behind us
2651 previously, it still is, and therefore
2652 it must not move. */
2656 /* Implementing circularity checking is trickier here
2657 than in other places because we have to guarantee
2658 that we've processed all elements before exiting
2659 due to a circularity. (In most places, an error
2660 is issued upon encountering a circularity, so it
2661 doesn't really matter if all elements are processed.)
2662 The idea is that we process along with the hare
2663 rather than the tortoise. If at any point in
2664 our forward process we encounter the tortoise,
2665 we must have already visited the spot, so we exit.
2666 (If we process with the tortoise, we can fail to
2667 process cases where a cons points to itself, or
2668 where cons A points to cons B, which points to
2671 rest2 = XCDR(rest2);
2673 tortoise = XCDR(tortoise);
2674 go_tortoise = !go_tortoise;
2675 if (EQ(rest2, tortoise))
2685 static enum weak_list_type decode_weak_list_type(Lisp_Object symbol)
2687 CHECK_SYMBOL(symbol);
2688 if (EQ(symbol, Qsimple))
2689 return WEAK_LIST_SIMPLE;
2690 if (EQ(symbol, Qassoc))
2691 return WEAK_LIST_ASSOC;
2692 if (EQ(symbol, Qold_assoc))
2693 return WEAK_LIST_ASSOC; /* EBOLA ALERT! */
2694 if (EQ(symbol, Qkey_assoc))
2695 return WEAK_LIST_KEY_ASSOC;
2696 if (EQ(symbol, Qvalue_assoc))
2697 return WEAK_LIST_VALUE_ASSOC;
2698 if (EQ(symbol, Qfull_assoc))
2699 return WEAK_LIST_FULL_ASSOC;
2701 signal_simple_error("Invalid weak list type", symbol);
2702 return WEAK_LIST_SIMPLE; /* not reached */
2705 static Lisp_Object encode_weak_list_type(enum weak_list_type type)
2708 case WEAK_LIST_SIMPLE:
2710 case WEAK_LIST_ASSOC:
2712 case WEAK_LIST_KEY_ASSOC:
2714 case WEAK_LIST_VALUE_ASSOC:
2715 return Qvalue_assoc;
2716 case WEAK_LIST_FULL_ASSOC:
2722 return Qnil; /* not reached */
2725 DEFUN("weak-list-p", Fweak_list_p, 1, 1, 0, /*
2726 Return non-nil if OBJECT is a weak list.
2730 return WEAK_LISTP(object) ? Qt : Qnil;
2733 DEFUN("make-weak-list", Fmake_weak_list, 0, 1, 0, /*
2734 Return a new weak list object of type TYPE.
2735 A weak list object is an object that contains a list. This list behaves
2736 like any other list except that its elements do not count towards
2737 garbage collection -- if the only pointer to an object is inside a weak
2738 list (other than pointers in similar objects such as weak hash tables),
2739 the object is garbage collected and automatically removed from the list.
2740 This is used internally, for example, to manage the list holding the
2741 children of an extent -- an extent that is unused but has a parent will
2742 still be reclaimed, and will automatically be removed from its parent's
2745 Optional argument TYPE specifies the type of the weak list, and defaults
2746 to `simple'. Recognized types are
2748 `simple' Objects in the list disappear if not pointed to.
2749 `assoc' Objects in the list disappear if they are conses
2750 and either the car or the cdr of the cons is not
2752 `key-assoc' Objects in the list disappear if they are conses
2753 and the car is not pointed to.
2754 `value-assoc' Objects in the list disappear if they are conses
2755 and the cdr is not pointed to.
2756 `full-assoc' Objects in the list disappear if they are conses
2757 and neither the car nor the cdr is pointed to.
2764 return make_weak_list(decode_weak_list_type(type));
2767 DEFUN("weak-list-type", Fweak_list_type, 1, 1, 0, /*
2768 Return the type of the given weak-list object.
2772 CHECK_WEAK_LIST(weak);
2773 return encode_weak_list_type(XWEAK_LIST(weak)->type);
2776 DEFUN("weak-list-list", Fweak_list_list, 1, 1, 0, /*
2777 Return the list contained in a weak-list object.
2781 CHECK_WEAK_LIST(weak);
2782 return XWEAK_LIST_LIST(weak);
2785 DEFUN("set-weak-list-list", Fset_weak_list_list, 2, 2, 0, /*
2786 Change the list contained in a weak-list object.
2790 CHECK_WEAK_LIST(weak);
2791 XWEAK_LIST_LIST(weak) = new_list;
2795 /************************************************************************/
2796 /* initialization */
2797 /************************************************************************/
2799 static SIGTYPE arith_error(int signo)
2801 EMACS_REESTABLISH_SIGNAL(signo, arith_error);
2802 EMACS_UNBLOCK_SIGNAL(signo);
2803 signal_error(Qarith_error, Qnil);
2806 void init_data_very_early(void)
2808 /* Don't do this if just dumping out.
2809 We don't want to call `signal' in this case
2810 so that we don't have trouble with dumping
2811 signal-delivering routines in an inconsistent state. */
2815 #endif /* CANNOT_DUMP */
2816 signal(SIGFPE, arith_error);
2818 signal(SIGEMT, arith_error);
2823 init_errors_once_early (void)
2825 DEFSYMBOL (Qerror_conditions);
2826 DEFSYMBOL (Qerror_message);
2828 /* We declare the errors here because some other deferrors depend
2829 on some of the errors below. */
2831 /* ERROR is used as a signaler for random errors for which nothing
2834 DEFERROR (Qerror, "error", Qnil);
2835 DEFERROR_STANDARD (Qquit, Qnil);
2837 DEFERROR_STANDARD (Qinvalid_argument, Qerror);
2839 DEFERROR_STANDARD (Qsyntax_error, Qinvalid_argument);
2840 DEFERROR_STANDARD (Qinvalid_read_syntax, Qsyntax_error);
2841 DEFERROR_STANDARD (Qstructure_formation_error, Qsyntax_error);
2842 DEFERROR_STANDARD (Qlist_formation_error, Qstructure_formation_error);
2843 DEFERROR_STANDARD (Qmalformed_list, Qlist_formation_error);
2844 DEFERROR_STANDARD (Qmalformed_property_list, Qmalformed_list);
2845 DEFERROR_STANDARD (Qcircular_list, Qlist_formation_error);
2846 DEFERROR_STANDARD (Qcircular_property_list, Qcircular_list);
2848 DEFERROR_STANDARD (Qwrong_type_argument, Qinvalid_argument);
2849 DEFERROR_STANDARD (Qargs_out_of_range, Qinvalid_argument);
2850 DEFERROR_STANDARD (Qwrong_number_of_arguments, Qinvalid_argument);
2851 DEFERROR_STANDARD (Qinvalid_function, Qinvalid_argument);
2852 DEFERROR_STANDARD (Qinvalid_constant, Qinvalid_argument);
2853 DEFERROR (Qno_catch, "No catch for tag", Qinvalid_argument);
2855 DEFERROR_STANDARD (Qinvalid_state, Qerror);
2856 DEFERROR (Qvoid_function, "Symbol's function definition is void",
2858 DEFERROR (Qcyclic_function_indirection,
2859 "Symbol's chain of function indirections contains a loop",
2861 DEFERROR (Qvoid_variable, "Symbol's value as variable is void",
2863 DEFERROR (Qcyclic_variable_indirection,
2864 "Symbol's chain of variable indirections contains a loop",
2866 DEFERROR_STANDARD (Qstack_overflow, Qinvalid_state);
2867 DEFERROR_STANDARD (Qinternal_error, Qinvalid_state);
2868 DEFERROR_STANDARD (Qout_of_memory, Qinvalid_state);
2870 DEFERROR_STANDARD (Qinvalid_operation, Qerror);
2871 DEFERROR_STANDARD (Qinvalid_change, Qinvalid_operation);
2872 DEFERROR (Qsetting_constant, "Attempt to set a constant symbol",
2874 DEFERROR_STANDARD (Qprinting_unreadable_object, Qinvalid_operation);
2875 DEFERROR (Qunimplemented, "Feature not yet implemented", Qinvalid_operation);
2877 DEFERROR_STANDARD (Qediting_error, Qinvalid_operation);
2878 DEFERROR_STANDARD (Qbeginning_of_buffer, Qediting_error);
2879 DEFERROR_STANDARD (Qend_of_buffer, Qediting_error);
2880 DEFERROR (Qbuffer_read_only, "Buffer is read-only", Qediting_error);
2882 DEFERROR (Qio_error, "IO Error", Qinvalid_operation);
2883 DEFERROR_STANDARD (Qfile_error, Qio_error);
2884 DEFERROR (Qend_of_file, "End of file or stream", Qfile_error);
2885 DEFERROR_STANDARD (Qconversion_error, Qio_error);
2886 DEFERROR_STANDARD (Qtext_conversion_error, Qconversion_error);
2888 DEFERROR (Qarith_error, "Arithmetic error", Qinvalid_operation);
2889 DEFERROR (Qrange_error, "Arithmetic range error", Qarith_error);
2890 DEFERROR (Qdomain_error, "Arithmetic domain error", Qarith_error);
2891 DEFERROR (Qsingularity_error, "Arithmetic singularity error", Qdomain_error);
2892 DEFERROR (Qoverflow_error, "Arithmetic overflow error", Qdomain_error);
2893 DEFERROR (Qunderflow_error, "Arithmetic underflow error", Qdomain_error);
2896 void syms_of_data(void)
2898 INIT_LRECORD_IMPLEMENTATION(weak_list);
2903 DEFSYMBOL(Qtrue_list_p);
2906 DEFSYMBOL(Qsymbolp);
2907 DEFSYMBOL(Qintegerp);
2908 DEFSYMBOL(Qcharacterp);
2909 DEFSYMBOL(Qnatnump);
2910 DEFSYMBOL(Qnonnegativep);
2911 DEFSYMBOL(Qpositivep);
2912 DEFSYMBOL(Qstringp);
2914 DEFSYMBOL(Qsequencep);
2916 DEFSYMBOL(Qbufferp);
2918 DEFSYMBOL_MULTIWORD_PREDICATE(Qbit_vectorp);
2919 DEFSYMBOL(Qvectorp);
2920 DEFSYMBOL(Qchar_or_string_p);
2921 DEFSYMBOL(Qmarkerp);
2922 DEFSYMBOL(Qinteger_or_marker_p);
2923 DEFSYMBOL(Qinteger_or_char_p);
2924 DEFSYMBOL(Qinteger_char_or_marker_p);
2925 DEFSYMBOL(Qnumberp);
2926 DEFSYMBOL(Qnumber_char_or_marker_p);
2928 DEFSYMBOL_MULTIWORD_PREDICATE(Qweak_listp);
2932 #endif /* HAVE_FPFLOAT */
2934 DEFSUBR(Fwrong_type_argument);
2939 Ffset(intern("not"), intern("null"));
2942 DEFSUBR(Ftrue_list_p);
2945 DEFSUBR(Fchar_or_string_p);
2946 DEFSUBR(Fcharacterp);
2947 DEFSUBR(Fchar_int_p);
2948 DEFSUBR(Fchar_to_int);
2949 DEFSUBR(Fint_to_char);
2950 DEFSUBR(Fchar_or_char_int_p);
2953 DEFSUBR(Finteger_or_marker_p);
2954 DEFSUBR(Finteger_or_char_p);
2955 DEFSUBR(Finteger_char_or_marker_p);
2957 DEFSUBR(Fnumber_or_marker_p);
2958 DEFSUBR(Fnumber_char_or_marker_p);
2961 #endif /* HAVE_FPFLOAT */
2963 DEFSUBR(Fnonnegativep);
2969 DEFSUBR(Fbit_vector_p);
2971 DEFSUBR(Fsequencep);
2974 DEFSUBR(Fsubr_min_args);
2975 DEFSUBR(Fsubr_max_args);
2976 DEFSUBR(Fsubr_interactive);
2984 DEFSUBR(Findirect_function);
2988 DEFSUBR(Fnumber_to_string);
2989 DEFSUBR(Fstring_to_number);
2997 #if defined(WITH_GMP) && defined(HAVE_MPZ)
2999 DEFSUBR(Fnext_prime);
3003 DEFSUBR(Ffactorial);
3004 DEFSUBR(Fbinomial_coefficient);
3005 DEFSUBR(Fremove_factor);
3006 DEFSUBR(Ffibonacci);
3007 DEFSUBR(Ffibonacci2);
3010 DEFSUBR(Fdivisiblep);
3011 DEFSUBR(Fcongruentp);
3012 DEFSUBR(Fperfect_power_p);
3013 DEFSUBR(Fperfect_square_p);
3014 DEFSUBR(Fintegral_sqrt);
3015 #if defined HAVE_ECM && defined WITH_ECM
3016 DEFSUBR(Ffactorise); /* some day maybe */
3017 #endif /* WITH_ECM && HAVE_ECM */
3018 #endif /* WITH_GMP && HAVE_MPZ */
3019 DEFSUBR(Fzero_divisor_p);
3020 DEFSUBR(Fweak_list_p);
3021 DEFSUBR(Fmake_weak_list);
3022 DEFSUBR(Fweak_list_type);
3023 DEFSUBR(Fweak_list_list);
3024 DEFSUBR(Fset_weak_list_list);
3027 void vars_of_data(void)
3029 /* This must not be staticpro'd */
3030 Vall_weak_lists = Qnil;
3031 dump_add_weak_object_chain(&Vall_weak_lists);
3033 #ifdef DEBUG_SXEMACS
3034 DEFVAR_BOOL("debug-issue-ebola-notices", &debug_issue_ebola_notices /*
3035 If non-zero, note when your code may be suffering from char-int confoundance.
3036 That is to say, if SXEmacs encounters a usage of `eq', `memq', `equal',
3037 etc. where an int and a char with the same value are being compared,
3038 it will issue a notice on stderr to this effect, along with a backtrace.
3039 In such situations, the result would be different in XEmacs 19 versus
3040 XEmacs 20, and you probably don't want this.
3042 Note that in order to see these notices, you have to byte compile your
3043 code under XEmacs 20 -- any code byte-compiled under XEmacs 19 will
3044 have its chars and ints all confounded in the byte code, making it
3045 impossible to accurately determine Ebola infection.
3048 debug_issue_ebola_notices = 0;
3050 DEFVAR_INT("debug-ebola-backtrace-length", &debug_ebola_backtrace_length /*
3051 Length (in stack frames) of short backtrace printed out in Ebola notices.
3052 See `debug-issue-ebola-notices'.
3054 debug_ebola_backtrace_length = 32;
3056 #endif /* DEBUG_SXEMACS */