Mercurial > hg > xemacs-beta

comparison src/data.c @ 380:8626e4521993 r21-2-5

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-5
author cvs
date Mon, 13 Aug 2007 11:07:10 +0200
parents cc15677e0335
children 74fd4e045ea6
comparison
equal deleted inserted replaced
379:76b7d63099ad 380:8626e4521993
50 Lisp_Object Qarith_error, Qrange_error, Qdomain_error; 50 Lisp_Object Qarith_error, Qrange_error, Qdomain_error;
51 Lisp_Object Qsingularity_error, Qoverflow_error, Qunderflow_error; 51 Lisp_Object Qsingularity_error, Qoverflow_error, Qunderflow_error;
52 Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only; 52 Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only;
53 Lisp_Object Qintegerp, Qnatnump, Qsymbolp, Qkeywordp; 53 Lisp_Object Qintegerp, Qnatnump, Qsymbolp, Qkeywordp;
54 Lisp_Object Qlistp, Qtrue_list_p, Qweak_listp; 54 Lisp_Object Qlistp, Qtrue_list_p, Qweak_listp;
55 Lisp_Object Qconsp, Qsubrp, Qcompiled_functionp; 55 Lisp_Object Qconsp, Qsubrp;
56 Lisp_Object Qcharacterp, Qstringp, Qarrayp, Qsequencep, Qvectorp; 56 Lisp_Object Qcharacterp, Qstringp, Qarrayp, Qsequencep, Qvectorp;
57 Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qbufferp; 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; 58 Lisp_Object Qinteger_or_char_p, Qinteger_char_or_marker_p;
59 Lisp_Object Qnumberp, Qnumber_or_marker_p, Qnumber_char_or_marker_p; 59 Lisp_Object Qnumberp, Qnumber_or_marker_p, Qnumber_char_or_marker_p;
60 Lisp_Object Qbit_vectorp, Qbitp, Qcons, Qkeyword, Qcdr, Qignore; 60 Lisp_Object Qbit_vectorp, Qbitp, Qcons, Qkeyword, Qcdr, Qignore;
75 #endif 75 #endif
76 76
77 int 77 int
78 eq_with_ebola_notice (Lisp_Object obj1, Lisp_Object obj2) 78 eq_with_ebola_notice (Lisp_Object obj1, Lisp_Object obj2)
79 { 79 {
80 if (((CHARP (obj1) && INTP (obj2)) || (CHARP (obj2) && INTP (obj1))) 80 if (debug_issue_ebola_notices != -42 /* abracadabra */ &&
81 && (debug_issue_ebola_notices >= 2 81 (((CHARP (obj1) && INTP (obj2)) || (CHARP (obj2) && INTP (obj1)))
82 || XCHAR_OR_INT (obj1) == XCHAR_OR_INT (obj2))) 82 && (debug_issue_ebola_notices >= 2
83 { 83 || XCHAR_OR_INT (obj1) == XCHAR_OR_INT (obj2))))
84 stderr_out("Comparison between integer and character is constant nil ("); 84 {
85 write_c_string ("Comparison between integer and character is constant nil (",
86 Qexternal_debugging_output);
85 Fprinc (obj1, Qexternal_debugging_output); 87 Fprinc (obj1, Qexternal_debugging_output);
86 stderr_out (" and "); 88 write_c_string (" and ", Qexternal_debugging_output);
87 Fprinc (obj2, Qexternal_debugging_output); 89 Fprinc (obj2, Qexternal_debugging_output);
88 stderr_out (")\n"); 90 write_c_string (")\n", Qexternal_debugging_output);
89 debug_short_backtrace (debug_ebola_backtrace_length); 91 debug_short_backtrace (debug_ebola_backtrace_length);
90 } 92 }
91 return EQ (obj1, obj2); 93 return EQ (obj1, obj2);
92 } 94 }
93 95
205 { 207 {
206 return NILP (object) ? Qt : Qnil; 208 return NILP (object) ? Qt : Qnil;
207 } 209 }
208 210
209 DEFUN ("consp", Fconsp, 1, 1, 0, /* 211 DEFUN ("consp", Fconsp, 1, 1, 0, /*
210 Return t if OBJECT is a cons cell. 212 Return t if OBJECT is a cons cell. `nil' is not a cons cell.
211 */ 213 */
212 (object)) 214 (object))
213 { 215 {
214 return CONSP (object) ? Qt : Qnil; 216 return CONSP (object) ? Qt : Qnil;
215 } 217 }
216 218
217 DEFUN ("atom", Fatom, 1, 1, 0, /* 219 DEFUN ("atom", Fatom, 1, 1, 0, /*
218 Return t if OBJECT is not a cons cell. Atoms include nil. 220 Return t if OBJECT is not a cons cell. `nil' is not a cons cell.
219 */ 221 */
220 (object)) 222 (object))
221 { 223 {
222 return CONSP (object) ? Qnil : Qt; 224 return CONSP (object) ? Qnil : Qt;
223 } 225 }
224 226
225 DEFUN ("listp", Flistp, 1, 1, 0, /* 227 DEFUN ("listp", Flistp, 1, 1, 0, /*
226 Return t if OBJECT is a list. Lists includes nil. 228 Return t if OBJECT is a list. `nil' is a list.
227 */ 229 */
228 (object)) 230 (object))
229 { 231 {
230 return LISTP (object) ? Qt : Qnil; 232 return LISTP (object) ? Qt : Qnil;
231 } 233 }
232 234
233 DEFUN ("nlistp", Fnlistp, 1, 1, 0, /* 235 DEFUN ("nlistp", Fnlistp, 1, 1, 0, /*
234 Return t if OBJECT is not a list. Lists include nil. 236 Return t if OBJECT is not a list. `nil' is a list.
235 */ 237 */
236 (object)) 238 (object))
237 { 239 {
238 return LISTP (object) ? Qnil : Qt; 240 return LISTP (object) ? Qnil : Qt;
239 } 241 }
261 { 263 {
262 return KEYWORDP (object) ? Qt : Qnil; 264 return KEYWORDP (object) ? Qt : Qnil;
263 } 265 }
264 266
265 DEFUN ("vectorp", Fvectorp, 1, 1, 0, /* 267 DEFUN ("vectorp", Fvectorp, 1, 1, 0, /*
266 REturn t if OBJECT is a vector. 268 Return t if OBJECT is a vector.
267 */ 269 */
268 (object)) 270 (object))
269 { 271 {
270 return VECTORP (object) ? Qt : Qnil; 272 return VECTORP (object) ? Qt : Qnil;
271 } 273 }
300 DEFUN ("sequencep", Fsequencep, 1, 1, 0, /* 302 DEFUN ("sequencep", Fsequencep, 1, 1, 0, /*
301 Return t if OBJECT is a sequence (list or array). 303 Return t if OBJECT is a sequence (list or array).
302 */ 304 */
303 (object)) 305 (object))
304 { 306 {
305 return (CONSP (object) || 307 return (LISTP (object) ||
306 NILP (object) ||
307 VECTORP (object) || 308 VECTORP (object) ||
308 STRINGP (object) || 309 STRINGP (object) ||
309 BIT_VECTORP (object)) 310 BIT_VECTORP (object))
310 ? Qt : Qnil; 311 ? Qt : Qnil;
311 } 312 }
359 { 360 {
360 CONST char *prompt; 361 CONST char *prompt;
361 CHECK_SUBR (subr); 362 CHECK_SUBR (subr);
362 prompt = XSUBR (subr)->prompt; 363 prompt = XSUBR (subr)->prompt;
363 return prompt ? list2 (Qinteractive, build_string (prompt)) : Qnil; 364 return prompt ? list2 (Qinteractive, build_string (prompt)) : Qnil;
364 }
365
366 DEFUN ("compiled-function-p", Fcompiled_function_p, 1, 1, 0, /*
367 Return t if OBJECT is a byte-compiled function object.
368 */
369 (object))
370 {
371 return COMPILED_FUNCTIONP (object) ? Qt : Qnil;
372 } 365 }
373 366
374 367
375 DEFUN ("characterp", Fcharacterp, 1, 1, 0, /* 368 DEFUN ("characterp", Fcharacterp, 1, 1, 0, /*
376 Return t if OBJECT is a character. 369 Return t if OBJECT is a character.
549 DEFUN ("type-of", Ftype_of, 1, 1, 0, /* 542 DEFUN ("type-of", Ftype_of, 1, 1, 0, /*
550 Return a symbol representing the type of OBJECT. 543 Return a symbol representing the type of OBJECT.
551 */ 544 */
552 (object)) 545 (object))
553 { 546 {
554 if (CONSP (object)) return Qcons; 547 switch (XTYPE (object))
555 if (SYMBOLP (object)) return Qsymbol; 548 {
556 if (KEYWORDP (object)) return Qkeyword; 549 #ifndef LRECORD_CONS
557 if (INTP (object)) return Qinteger; 550 case Lisp_Type_Cons: return Qcons;
558 if (CHARP (object)) return Qcharacter; 551 #endif
559 if (STRINGP (object)) return Qstring; 552
560 if (VECTORP (object)) return Qvector; 553 #ifndef LRECORD_SYMBOL
561 554 case Lisp_Type_Symbol: return Qsymbol;
562 assert (LRECORDP (object)); 555 #endif
563 return intern (XRECORD_LHEADER_IMPLEMENTATION (object)->name); 556
557 #ifndef LRECORD_STRING
558 case Lisp_Type_String: return Qstring;
559 #endif
560
561 #ifndef LRECORD_VECTOR
562 case Lisp_Type_Vector: return Qvector;
563 #endif
564
565 case Lisp_Type_Record:
566 return intern (XRECORD_LHEADER_IMPLEMENTATION (object)->name);
567
568 case Lisp_Type_Char: return Qcharacter;
569
570 default: return Qinteger;
571 }
564 } 572 }
565 573
566 574
567 /* Extract and set components of lists */ 575 /* Extract and set components of lists */
568 576
640 CHECK_IMPURE (conscell); 648 CHECK_IMPURE (conscell);
641 XCDR (conscell) = newcdr; 649 XCDR (conscell) = newcdr;
642 return newcdr; 650 return newcdr;
643 } 651 }
644 652
645 /* Find the function at the end of a chain of symbol function indirections. */ 653 /* Find the function at the end of a chain of symbol function indirections.
646 654
647 /* If OBJECT is a symbol, find the end of its function chain and 655 If OBJECT is a symbol, find the end of its function chain and
648 return the value found there. If OBJECT is not a symbol, just 656 return the value found there. If OBJECT is not a symbol, just
649 return it. If there is a cycle in the function chain, signal a 657 return it. If there is a cycle in the function chain, signal a
650 cyclic-function-indirection error. 658 cyclic-function-indirection error.
651 659
652 This is like Findirect_function, except that it doesn't signal an 660 This is like Findirect_function, except that it doesn't signal an
653 error if the chain ends up unbound. */ 661 error if the chain ends up unbound. */
654 Lisp_Object 662 Lisp_Object
655 indirect_function (Lisp_Object object, int errorp) 663 indirect_function (Lisp_Object object, int errorp)
656 { 664 {
657 Lisp_Object tortoise = object; 665 #define FUNCTION_INDIRECTION_SUSPICION_LENGTH 16
658 Lisp_Object hare = object; 666 Lisp_Object tortoise, hare;
659 667 int count;
660 for (;;) 668
661 { 669 for (hare = tortoise = object, count = 0;
662 if (!SYMBOLP (hare) || UNBOUNDP (hare)) 670 SYMBOLP (hare);
663 break; 671 hare = XSYMBOL (hare)->function, count++)
664 hare = XSYMBOL (hare)->function; 672 {
665 if (!SYMBOLP (hare) || UNBOUNDP (hare)) 673 if (count < FUNCTION_INDIRECTION_SUSPICION_LENGTH) continue;
666 break; 674
667 hare = XSYMBOL (hare)->function; 675 if (count & 1)
668 676 tortoise = XSYMBOL (tortoise)->function;
669 tortoise = XSYMBOL (tortoise)->function;
670
671 if (EQ (hare, tortoise)) 677 if (EQ (hare, tortoise))
672 return Fsignal (Qcyclic_function_indirection, list1 (object)); 678 return Fsignal (Qcyclic_function_indirection, list1 (object));
673 } 679 }
674 680
675 if (UNBOUNDP (hare) && errorp) 681 if (errorp && UNBOUNDP (hare))
676 return Fsignal (Qvoid_function, list1 (object)); 682 signal_void_function_error (object);
683
677 return hare; 684 return hare;
678 } 685 }
679 686
680 DEFUN ("indirect-function", Findirect_function, 1, 1, 0, /* 687 DEFUN ("indirect-function", Findirect_function, 1, 1, 0, /*
681 Return the function at the end of OBJECT's function chain. 688 Return the function at the end of OBJECT's function chain.
693 700
694 /* Extract and set vector and string elements */ 701 /* Extract and set vector and string elements */
695 702
696 DEFUN ("aref", Faref, 2, 2, 0, /* 703 DEFUN ("aref", Faref, 2, 2, 0, /*
697 Return the element of ARRAY at index INDEX. 704 Return the element of ARRAY at index INDEX.
698 ARRAY may be a vector, bit vector, string, or byte-code object. 705 ARRAY may be a vector, bit vector, or string. INDEX starts at 0.
699 IDX starts at 0. 706 */
700 */ 707 (array, index_))
701 (array, idx)) 708 {
702 { 709 int idx;
703 int idxval;
704 710
705 retry: 711 retry:
706 CHECK_INT_COERCE_CHAR (idx); /* yuck! */ 712
707 idxval = XINT (idx); 713 if (INTP (index_)) idx = XINT (index_);
708 if (idxval < 0) 714 else if (CHARP (index_)) idx = XCHAR (index_); /* yuck! */
709 { 715 else
710 lose: 716 {
711 args_out_of_range (array, idx); 717 index_ = wrong_type_argument (Qinteger_or_char_p, index_);
712 } 718 goto retry;
719 }
720
721 if (idx < 0) goto range_error;
722
713 if (VECTORP (array)) 723 if (VECTORP (array))
714 { 724 {
715 if (idxval >= XVECTOR_LENGTH (array)) goto lose; 725 if (idx >= XVECTOR_LENGTH (array)) goto range_error;
716 return XVECTOR_DATA (array)[idxval]; 726 return XVECTOR_DATA (array)[idx];
717 } 727 }
718 else if (BIT_VECTORP (array)) 728 else if (BIT_VECTORP (array))
719 { 729 {
720 if (idxval >= bit_vector_length (XBIT_VECTOR (array))) goto lose; 730 if (idx >= bit_vector_length (XBIT_VECTOR (array))) goto range_error;
721 return make_int (bit_vector_bit (XBIT_VECTOR (array), idxval)); 731 return make_int (bit_vector_bit (XBIT_VECTOR (array), idx));
722 } 732 }
723 else if (STRINGP (array)) 733 else if (STRINGP (array))
724 { 734 {
725 if (idxval >= XSTRING_CHAR_LENGTH (array)) goto lose; 735 if (idx >= XSTRING_CHAR_LENGTH (array)) goto range_error;
726 return make_char (string_char (XSTRING (array), idxval)); 736 return make_char (string_char (XSTRING (array), idx));
727 } 737 }
728 #ifdef LOSING_BYTECODE 738 #ifdef LOSING_BYTECODE
729 else if (COMPILED_FUNCTIONP (array)) 739 else if (COMPILED_FUNCTIONP (array))
730 { 740 {
731 /* Weird, gross compatibility kludge */ 741 /* Weird, gross compatibility kludge */
732 return Felt (array, idx); 742 return Felt (array, index_);
733 } 743 }
734 #endif 744 #endif
735 else 745 else
736 { 746 {
737 check_losing_bytecode ("aref", array); 747 check_losing_bytecode ("aref", array);
738 array = wrong_type_argument (Qarrayp, array); 748 array = wrong_type_argument (Qarrayp, array);
739 goto retry; 749 goto retry;
740 } 750 }
751
752 range_error:
753 args_out_of_range (array, index_);
754 return Qnil; /* not reached */
741 } 755 }
742 756
743 DEFUN ("aset", Faset, 3, 3, 0, /* 757 DEFUN ("aset", Faset, 3, 3, 0, /*
744 Store into the element of ARRAY at index IDX the value NEWVAL. 758 Store into the element of ARRAY at index INDEX the value NEWVAL.
745 ARRAY may be a vector, bit vector, or string. IDX starts at 0. 759 ARRAY may be a vector, bit vector, or string. INDEX starts at 0.
746 */ 760 */
747 (array, idx, newval)) 761 (array, index_, newval))
748 { 762 {
749 int idxval; 763 int idx;
750 764
751 CHECK_INT_COERCE_CHAR (idx); /* yuck! */ 765 retry:
752 if (!VECTORP (array) && !BIT_VECTORP (array) && !STRINGP (array)) 766
753 array = wrong_type_argument (Qarrayp, array); 767 if (INTP (index_)) idx = XINT (index_);
754 768 else if (CHARP (index_)) idx = XCHAR (index_); /* yuck! */
755 idxval = XINT (idx); 769 else
756 if (idxval < 0) 770 {
757 { 771 index_ = wrong_type_argument (Qinteger_or_char_p, index_);
758 lose: 772 goto retry;
759 args_out_of_range (array, idx); 773 }
760 } 774
775 if (idx < 0) goto range_error;
776
761 CHECK_IMPURE (array); 777 CHECK_IMPURE (array);
762 778
763 if (VECTORP (array)) 779 if (VECTORP (array))
764 { 780 {
765 if (idxval >= XVECTOR_LENGTH (array)) goto lose; 781 if (idx >= XVECTOR_LENGTH (array)) goto range_error;
766 XVECTOR_DATA (array)[idxval] = newval; 782 XVECTOR_DATA (array)[idx] = newval;
767 } 783 }
768 else if (BIT_VECTORP (array)) 784 else if (BIT_VECTORP (array))
769 { 785 {
770 if (idxval >= bit_vector_length (XBIT_VECTOR (array))) goto lose; 786 if (idx >= bit_vector_length (XBIT_VECTOR (array))) goto range_error;
771 CHECK_BIT (newval); 787 CHECK_BIT (newval);
772 set_bit_vector_bit (XBIT_VECTOR (array), idxval, !ZEROP (newval)); 788 set_bit_vector_bit (XBIT_VECTOR (array), idx, !ZEROP (newval));
773 } 789 }
774 else /* string */ 790 else if (STRINGP (array))
775 { 791 {
776 CHECK_CHAR_COERCE_INT (newval); 792 CHECK_CHAR_COERCE_INT (newval);
777 if (idxval >= XSTRING_CHAR_LENGTH (array)) goto lose; 793 if (idx >= XSTRING_CHAR_LENGTH (array)) goto range_error;
778 set_string_char (XSTRING (array), idxval, XCHAR (newval)); 794 set_string_char (XSTRING (array), idx, XCHAR (newval));
779 bump_string_modiff (array); 795 bump_string_modiff (array);
780 } 796 }
797 else
798 {
799 array = wrong_type_argument (Qarrayp, array);
800 goto retry;
801 }
781 802
782 return newval; 803 return newval;
783 } 804
784 805 range_error:
785 806 args_out_of_range (array, index_);
786 /**********************************************************************/ 807 return Qnil; /* not reached */
787 /* Compiled-function objects */
788 /**********************************************************************/
789
790 /* The compiled_function->doc_and_interactive slot uses the minimal
791 number of conses, based on compiled_function->flags; it may take
792 any of the following forms:
793
794 doc
795 interactive
796 domain
797 (doc . interactive)
798 (doc . domain)
799 (interactive . domain)
800 (doc . (interactive . domain))
801 */
802
803 /* Caller must check flags.interactivep first */
804 Lisp_Object
805 compiled_function_interactive (struct Lisp_Compiled_Function *b)
806 {
807 assert (b->flags.interactivep);
808 if (b->flags.documentationp && b->flags.domainp)
809 return XCAR (XCDR (b->doc_and_interactive));
810 else if (b->flags.documentationp)
811 return XCDR (b->doc_and_interactive);
812 else if (b->flags.domainp)
813 return XCAR (b->doc_and_interactive);
814
815 /* if all else fails... */
816 return b->doc_and_interactive;
817 }
818
819 /* Caller need not check flags.documentationp first */
820 Lisp_Object
821 compiled_function_documentation (struct Lisp_Compiled_Function *b)
822 {
823 if (! b->flags.documentationp)
824 return Qnil;
825 else if (b->flags.interactivep && b->flags.domainp)
826 return XCAR (b->doc_and_interactive);
827 else if (b->flags.interactivep)
828 return XCAR (b->doc_and_interactive);
829 else if (b->flags.domainp)
830 return XCAR (b->doc_and_interactive);
831 else
832 return b->doc_and_interactive;
833 }
834
835 /* Caller need not check flags.domainp first */
836 Lisp_Object
837 compiled_function_domain (struct Lisp_Compiled_Function *b)
838 {
839 if (! b->flags.domainp)
840 return Qnil;
841 else if (b->flags.documentationp && b->flags.interactivep)
842 return XCDR (XCDR (b->doc_and_interactive));
843 else if (b->flags.documentationp)
844 return XCDR (b->doc_and_interactive);
845 else if (b->flags.interactivep)
846 return XCDR (b->doc_and_interactive);
847 else
848 return b->doc_and_interactive;
849 }
850
851 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
852
853 Lisp_Object
854 compiled_function_annotation (struct Lisp_Compiled_Function *b)
855 {
856 return b->annotated;
857 }
858
859 #endif
860
861 /* used only by Snarf-documentation; there must be doc already. */
862 void
863 set_compiled_function_documentation (struct Lisp_Compiled_Function *b,
864 Lisp_Object new)
865 {
866 assert (b->flags.documentationp);
867 assert (INTP (new) || STRINGP (new));
868
869 if (b->flags.interactivep && b->flags.domainp)
870 XCAR (b->doc_and_interactive) = new;
871 else if (b->flags.interactivep)
872 XCAR (b->doc_and_interactive) = new;
873 else if (b->flags.domainp)
874 XCAR (b->doc_and_interactive) = new;
875 else
876 b->doc_and_interactive = new;
877 }
878
879 DEFUN ("compiled-function-instructions", Fcompiled_function_instructions, 1, 1, 0, /*
880 Return the byte-opcode string of the compiled-function object.
881 */
882 (function))
883 {
884 CHECK_COMPILED_FUNCTION (function);
885 return XCOMPILED_FUNCTION (function)->bytecodes;
886 }
887
888 DEFUN ("compiled-function-constants", Fcompiled_function_constants, 1, 1, 0, /*
889 Return the constants vector of the compiled-function object.
890 */
891 (function))
892 {
893 CHECK_COMPILED_FUNCTION (function);
894 return XCOMPILED_FUNCTION (function)->constants;
895 }
896
897 DEFUN ("compiled-function-stack-depth", Fcompiled_function_stack_depth, 1, 1, 0, /*
898 Return the max stack depth of the compiled-function object.
899 */
900 (function))
901 {
902 CHECK_COMPILED_FUNCTION (function);
903 return make_int (XCOMPILED_FUNCTION (function)->maxdepth);
904 }
905
906 DEFUN ("compiled-function-arglist", Fcompiled_function_arglist, 1, 1, 0, /*
907 Return the argument list of the compiled-function object.
908 */
909 (function))
910 {
911 CHECK_COMPILED_FUNCTION (function);
912 return XCOMPILED_FUNCTION (function)->arglist;
913 }
914
915 DEFUN ("compiled-function-interactive", Fcompiled_function_interactive, 1, 1, 0, /*
916 Return the interactive spec of the compiled-function object, or nil.
917 If non-nil, the return value will be a list whose first element is
918 `interactive' and whose second element is the interactive spec.
919 */
920 (function))
921 {
922 CHECK_COMPILED_FUNCTION (function);
923 return XCOMPILED_FUNCTION (function)->flags.interactivep
924 ? list2 (Qinteractive,
925 compiled_function_interactive (XCOMPILED_FUNCTION (function)))
926 : Qnil;
927 }
928
929 DEFUN ("compiled-function-doc-string", Fcompiled_function_doc_string, 1, 1, 0, /*
930 Return the doc string of the compiled-function object, if available.
931 Functions that had their doc strings snarfed into the DOC file will have
932 an integer returned instead of a string.
933 */
934 (function))
935 {
936 CHECK_COMPILED_FUNCTION (function);
937 return compiled_function_documentation (XCOMPILED_FUNCTION (function));
938 }
939
940 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
941
942 /* Remove the `xx' if you wish to restore this feature */
943 xxDEFUN ("compiled-function-annotation", Fcompiled_function_annotation, 1, 1, 0, /*
944 Return the annotation of the compiled-function object, or nil.
945 The annotation is a piece of information indicating where this
946 compiled-function object came from. Generally this will be
947 a symbol naming a function; or a string naming a file, if the
948 compiled-function object was not defined in a function; or nil,
949 if the compiled-function object was not created as a result of
950 a `load'.
951 */
952 (function))
953 {
954 CHECK_COMPILED_FUNCTION (function);
955 return compiled_function_annotation (XCOMPILED_FUNCTION (function));
956 }
957
958 #endif /* COMPILED_FUNCTION_ANNOTATION_HACK */
959
960 DEFUN ("compiled-function-domain", Fcompiled_function_domain, 1, 1, 0, /*
961 Return the domain of the compiled-function object, or nil.
962 This is only meaningful if I18N3 was enabled when emacs was compiled.
963 */
964 (function))
965 {
966 CHECK_COMPILED_FUNCTION (function);
967 return XCOMPILED_FUNCTION (function)->flags.domainp
968 ? compiled_function_domain (XCOMPILED_FUNCTION (function))
969 : Qnil;
970 } 808 }
971 809
972 810
973 /**********************************************************************/ 811 /**********************************************************************/
974 /* Arithmetic functions */ 812 /* Arithmetic functions */
975 /**********************************************************************/ 813 /**********************************************************************/
976 814 typedef struct
977 Lisp_Object 815 {
978 arithcompare (Lisp_Object num1, Lisp_Object num2, 816 int int_p;
979 enum arith_comparison comparison) 817 union
980 { 818 {
981 CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (num1); 819 int ival;
982 CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (num2); 820 double dval;
983 821 } c;
822 } int_or_double;
823
824 static void
825 number_char_or_marker_to_int_or_double (Lisp_Object obj, int_or_double *p)
826 {
827 retry:
828 p->int_p = 1;
829 if (INTP (obj)) p->c.ival = XINT (obj);
830 else if (CHARP (obj)) p->c.ival = XCHAR (obj);
831 else if (MARKERP (obj)) p->c.ival = marker_position (obj);
984 #ifdef LISP_FLOAT_TYPE 832 #ifdef LISP_FLOAT_TYPE
985 if (FLOATP (num1) || FLOATP (num2)) 833 else if (FLOATP (obj)) p->c.dval = XFLOAT_DATA (obj), p->int_p = 0;
986 { 834 #endif
987 double f1 = FLOATP (num1) ? float_data (XFLOAT (num1)) : XINT (num1); 835 else
988 double f2 = FLOATP (num2) ? float_data (XFLOAT (num2)) : XINT (num2); 836 {
989 837 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
990 switch (comparison) 838 goto retry;
991 { 839 }
992 case arith_equal: return f1 == f2 ? Qt : Qnil; 840 }
993 case arith_notequal: return f1 != f2 ? Qt : Qnil; 841
994 case arith_less: return f1 < f2 ? Qt : Qnil; 842 static double
995 case arith_less_or_equal: return f1 <= f2 ? Qt : Qnil; 843 number_char_or_marker_to_double (Lisp_Object obj)
996 case arith_grtr: return f1 > f2 ? Qt : Qnil; 844 {
997 case arith_grtr_or_equal: return f1 >= f2 ? Qt : Qnil; 845 retry:
998 } 846 if (INTP (obj)) return (double) XINT (obj);
999 } 847 else if (CHARP (obj)) return (double) XCHAR (obj);
1000 #endif /* LISP_FLOAT_TYPE */ 848 else if (MARKERP (obj)) return (double) marker_position (obj);
1001 849 #ifdef LISP_FLOAT_TYPE
1002 switch (comparison) 850 else if (FLOATP (obj)) return XFLOAT_DATA (obj);
1003 { 851 #endif
1004 case arith_equal: return XINT (num1) == XINT (num2) ? Qt : Qnil; 852 else
1005 case arith_notequal: return XINT (num1) != XINT (num2) ? Qt : Qnil; 853 {
1006 case arith_less: return XINT (num1) < XINT (num2) ? Qt : Qnil; 854 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
1007 case arith_less_or_equal: return XINT (num1) <= XINT (num2) ? Qt : Qnil; 855 goto retry;
1008 case arith_grtr: return XINT (num1) > XINT (num2) ? Qt : Qnil; 856 }
1009 case arith_grtr_or_equal: return XINT (num1) >= XINT (num2) ? Qt : Qnil; 857 }
1010 } 858
1011 859 static int
1012 abort (); 860 integer_char_or_marker_to_int (Lisp_Object obj)
1013 return Qnil; /* suppress compiler warning */ 861 {
1014 } 862 retry:
1015 863 if (INTP (obj)) return XINT (obj);
1016 static Lisp_Object 864 else if (CHARP (obj)) return XCHAR (obj);
1017 arithcompare_many (enum arith_comparison comparison, 865 else if (MARKERP (obj)) return marker_position (obj);
1018 int nargs, Lisp_Object *args) 866 else
1019 { 867 {
1020 for (; --nargs > 0; args++) 868 obj = wrong_type_argument (Qinteger_char_or_marker_p, obj);
1021 if (NILP (arithcompare (*args, *(args + 1), comparison))) 869 goto retry;
1022 return Qnil; 870 }
1023 871 }
1024 return Qt; 872
873 #define ARITHCOMPARE_MANY(op) \
874 { \
875 int_or_double iod1, iod2, *p = &iod1, *q = &iod2; \
876 Lisp_Object *args_end = args + nargs; \
877 \
878 number_char_or_marker_to_int_or_double (*args++, p); \
879 \
880 while (args < args_end) \
881 { \
882 number_char_or_marker_to_int_or_double (*args++, q); \
883 \
884 if (!((p->int_p && q->int_p) ? \
885 (p->c.ival op q->c.ival) : \
886 ((p->int_p ? (double) p->c.ival : p->c.dval) op \
887 (q->int_p ? (double) q->c.ival : q->c.dval)))) \
888 return Qnil; \
889 \
890 { /* swap */ int_or_double *r = p; p = q; q = r; } \
891 } \
892 return Qt; \
1025 } 893 }
1026 894
1027 DEFUN ("=", Feqlsign, 1, MANY, 0, /* 895 DEFUN ("=", Feqlsign, 1, MANY, 0, /*
1028 Return t if all the arguments are numerically equal. 896 Return t if all the arguments are numerically equal.
1029 The arguments may be numbers, characters or markers. 897 The arguments may be numbers, characters or markers.
1030 */ 898 */
1031 (int nargs, Lisp_Object *args)) 899 (int nargs, Lisp_Object *args))
1032 { 900 {
1033 return arithcompare_many (arith_equal, nargs, args); 901 ARITHCOMPARE_MANY (==)
1034 } 902 }
1035 903
1036 DEFUN ("<", Flss, 1, MANY, 0, /* 904 DEFUN ("<", Flss, 1, MANY, 0, /*
1037 Return t if the sequence of arguments is monotonically increasing. 905 Return t if the sequence of arguments is monotonically increasing.
1038 The arguments may be numbers, characters or markers. 906 The arguments may be numbers, characters or markers.
1039 */ 907 */
1040 (int nargs, Lisp_Object *args)) 908 (int nargs, Lisp_Object *args))
1041 { 909 {
1042 return arithcompare_many (arith_less, nargs, args); 910 ARITHCOMPARE_MANY (<)
1043 } 911 }
1044 912
1045 DEFUN (">", Fgtr, 1, MANY, 0, /* 913 DEFUN (">", Fgtr, 1, MANY, 0, /*
1046 Return t if the sequence of arguments is monotonically decreasing. 914 Return t if the sequence of arguments is monotonically decreasing.
1047 The arguments may be numbers, characters or markers. 915 The arguments may be numbers, characters or markers.
1048 */ 916 */
1049 (int nargs, Lisp_Object *args)) 917 (int nargs, Lisp_Object *args))
1050 { 918 {
1051 return arithcompare_many (arith_grtr, nargs, args); 919 ARITHCOMPARE_MANY (>)
1052 } 920 }
1053 921
1054 DEFUN ("<=", Fleq, 1, MANY, 0, /* 922 DEFUN ("<=", Fleq, 1, MANY, 0, /*
1055 Return t if the sequence of arguments is monotonically nondecreasing. 923 Return t if the sequence of arguments is monotonically nondecreasing.
1056 The arguments may be numbers, characters or markers. 924 The arguments may be numbers, characters or markers.
1057 */ 925 */
1058 (int nargs, Lisp_Object *args)) 926 (int nargs, Lisp_Object *args))
1059 { 927 {
1060 return arithcompare_many (arith_less_or_equal, nargs, args); 928 ARITHCOMPARE_MANY (<=)
1061 } 929 }
1062 930
1063 DEFUN (">=", Fgeq, 1, MANY, 0, /* 931 DEFUN (">=", Fgeq, 1, MANY, 0, /*
1064 Return t if the sequence of arguments is monotonically nonincreasing. 932 Return t if the sequence of arguments is monotonically nonincreasing.
1065 The arguments may be numbers, characters or markers. 933 The arguments may be numbers, characters or markers.
1066 */ 934 */
1067 (int nargs, Lisp_Object *args)) 935 (int nargs, Lisp_Object *args))
1068 { 936 {
1069 return arithcompare_many (arith_grtr_or_equal, nargs, args); 937 ARITHCOMPARE_MANY (>=)
1070 } 938 }
1071 939
1072 DEFUN ("/=", Fneq, 1, MANY, 0, /* 940 DEFUN ("/=", Fneq, 1, MANY, 0, /*
1073 Return t if no two arguments are numerically equal. 941 Return t if no two arguments are numerically equal.
1074 The arguments may be numbers, characters or markers. 942 The arguments may be numbers, characters or markers.
1075 */ 943 */
1076 (int nargs, Lisp_Object *args)) 944 (int nargs, Lisp_Object *args))
1077 { 945 {
1078 return arithcompare_many (arith_notequal, nargs, args); 946 Lisp_Object *args_end = args + nargs;
947 Lisp_Object *p, *q;
948
949 /* Unlike all the other comparisons, this is an N*N algorithm.
950 We could use a hash table for nargs > 50 to make this linear. */
951 for (p = args; p < args_end; p++)
952 {
953 int_or_double iod1, iod2;
954 number_char_or_marker_to_int_or_double (*p, &iod1);
955
956 for (q = p + 1; q < args_end; q++)
957 {
958 number_char_or_marker_to_int_or_double (*q, &iod2);
959
960 if (!((iod1.int_p && iod2.int_p) ?
961 (iod1.c.ival != iod2.c.ival) :
962 ((iod1.int_p ? (double) iod1.c.ival : iod1.c.dval) !=
963 (iod2.int_p ? (double) iod2.c.ival : iod2.c.dval))))
964 return Qnil;
965 }
966 }
967 return Qt;
1079 } 968 }
1080 969
1081 DEFUN ("zerop", Fzerop, 1, 1, 0, /* 970 DEFUN ("zerop", Fzerop, 1, 1, 0, /*
1082 Return t if NUMBER is zero. 971 Return t if NUMBER is zero.
1083 */ 972 */
1084 (number)) 973 (number))
1085 { 974 {
1086 CHECK_INT_OR_FLOAT (number); 975 retry:
1087 976 if (INTP (number))
977 return EQ (number, Qzero) ? Qt : Qnil;
1088 #ifdef LISP_FLOAT_TYPE 978 #ifdef LISP_FLOAT_TYPE
1089 if (FLOATP (number)) 979 else if (FLOATP (number))
1090 return float_data (XFLOAT (number)) == 0.0 ? Qt : Qnil; 980 return XFLOAT_DATA (number) == 0.0 ? Qt : Qnil;
1091 #endif /* LISP_FLOAT_TYPE */ 981 #endif /* LISP_FLOAT_TYPE */
1092 982 else
1093 return EQ (number, Qzero) ? Qt : Qnil; 983 {
984 number = wrong_type_argument (Qnumberp, number);
985 goto retry;
986 }
1094 } 987 }
1095 988
1096 /* Convert between a 32-bit value and a cons of two 16-bit values. 989 /* Convert between a 32-bit value and a cons of two 16-bit values.
1097 This is used to pass 32-bit integers to and from the user. 990 This is used to pass 32-bit integers to and from the user.
1098 Use time_to_lisp() and lisp_to_time() for time values. 991 Use time_to_lisp() and lisp_to_time() for time values.
1136 #ifdef LISP_FLOAT_TYPE 1029 #ifdef LISP_FLOAT_TYPE
1137 if (FLOATP (num)) 1030 if (FLOATP (num))
1138 { 1031 {
1139 char pigbuf[350]; /* see comments in float_to_string */ 1032 char pigbuf[350]; /* see comments in float_to_string */
1140 1033
1141 float_to_string (pigbuf, float_data (XFLOAT (num))); 1034 float_to_string (pigbuf, XFLOAT_DATA (num));
1142 return build_string (pigbuf); 1035 return build_string (pigbuf);
1143 } 1036 }
1144 #endif /* LISP_FLOAT_TYPE */ 1037 #endif /* LISP_FLOAT_TYPE */
1145 1038
1146 long_to_string (buffer, XINT (num)); 1039 long_to_string (buffer, XINT (num));
1197 #endif /* LISP_FLOAT_TYPE */ 1090 #endif /* LISP_FLOAT_TYPE */
1198 1091
1199 if (b == 10) 1092 if (b == 10)
1200 { 1093 {
1201 /* Use the system-provided functions for base 10. */ 1094 /* Use the system-provided functions for base 10. */
1202 #if SIZEOF_EMACS_INT == SIZEOF_INT 1095 #if SIZEOF_EMACS_INT == SIZEOF_INT
1203 return make_int (atoi (p)); 1096 return make_int (atoi (p));
1204 #elif SIZEOF_EMACS_INT == SIZEOF_LONG 1097 #elif SIZEOF_EMACS_INT == SIZEOF_LONG
1205 return make_int (atol (p)); 1098 return make_int (atol (p));
1206 #elif SIZEOF_EMACS_INT == SIZEOF_LONG_LONG 1099 #elif SIZEOF_EMACS_INT == SIZEOF_LONG_LONG
1207 return make_int (atoll (p)); 1100 return make_int (atoll (p));
1228 } 1121 }
1229 return make_int (negative * v); 1122 return make_int (negative * v);
1230 } 1123 }
1231 } 1124 }
1232 1125
1233 enum arithop 1126
1234 { Aadd, Asub, Amult, Adiv, Alogand, Alogior, Alogxor, Amax, Amin }; 1127 DEFUN ("+", Fplus, 0, MANY, 0, /*
1235 1128 Return sum of any number of arguments.
1236 1129 The arguments should all be numbers, characters or markers.
1237 #ifdef LISP_FLOAT_TYPE 1130 */
1238 static Lisp_Object 1131 (int nargs, Lisp_Object *args))
1239 float_arith_driver (double accum, int argnum, enum arithop code, int nargs, 1132 {
1240 Lisp_Object *args) 1133 EMACS_INT iaccum = 0;
1241 { 1134 Lisp_Object *args_end = args + nargs;
1242 REGISTER Lisp_Object val; 1135
1243 double next; 1136 while (args < args_end)
1244 1137 {
1245 for (; argnum < nargs; argnum++) 1138 int_or_double iod;
1246 { 1139 number_char_or_marker_to_int_or_double (*args++, &iod);
1247 /* using args[argnum] as argument to CHECK_INT_OR_FLOAT_... */ 1140 if (iod.int_p)
1248 val = args[argnum]; 1141 iaccum += iod.c.ival;
1249 CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (val); 1142 else
1250
1251 if (FLOATP (val))
1252 { 1143 {
1253 next = float_data (XFLOAT (val)); 1144 double daccum = (double) iaccum + iod.c.dval;
1145 while (args < args_end)
1146 daccum += number_char_or_marker_to_double (*args++);
1147 return make_float (daccum);
1148 }
1149 }
1150
1151 return make_int (iaccum);
1152 }
1153
1154 DEFUN ("-", Fminus, 1, MANY, 0, /*
1155 Negate number or subtract numbers, characters or markers.
1156 With one arg, negates it. With more than one arg,
1157 subtracts all but the first from the first.
1158 */
1159 (int nargs, Lisp_Object *args))
1160 {
1161 EMACS_INT iaccum;
1162 double daccum;
1163 Lisp_Object *args_end = args + nargs;
1164 int_or_double iod;
1165
1166 number_char_or_marker_to_int_or_double (*args++, &iod);
1167 if (iod.int_p)
1168 iaccum = nargs > 1 ? iod.c.ival : - iod.c.ival;
1169 else
1170 {
1171 daccum = nargs > 1 ? iod.c.dval : - iod.c.dval;
1172 goto do_float;
1173 }
1174
1175 while (args < args_end)
1176 {
1177 number_char_or_marker_to_int_or_double (*args++, &iod);
1178 if (iod.int_p)
1179 iaccum -= iod.c.ival;
1180 else
1181 {
1182 daccum = (double) iaccum - iod.c.dval;
1183 goto do_float;
1184 }
1185 }
1186
1187 return make_int (iaccum);
1188
1189 do_float:
1190 for (; args < args_end; args++)
1191 daccum -= number_char_or_marker_to_double (*args);
1192 return make_float (daccum);
1193 }
1194
1195 DEFUN ("*", Ftimes, 0, MANY, 0, /*
1196 Return product of any number of arguments.
1197 The arguments should all be numbers, characters or markers.
1198 */
1199 (int nargs, Lisp_Object *args))
1200 {
1201 EMACS_INT iaccum = 1;
1202 Lisp_Object *args_end = args + nargs;
1203
1204 while (args < args_end)
1205 {
1206 int_or_double iod;
1207 number_char_or_marker_to_int_or_double (*args++, &iod);
1208 if (iod.int_p)
1209 iaccum *= iod.c.ival;
1210 else
1211 {
1212 double daccum = (double) iaccum * iod.c.dval;
1213 while (args < args_end)
1214 daccum *= number_char_or_marker_to_double (*args++);
1215 return make_float (daccum);
1216 }
1217 }
1218
1219 return make_int (iaccum);
1220 }
1221
1222 DEFUN ("/", Fquo, 1, MANY, 0, /*
1223 Return first argument divided by all the remaining arguments.
1224 The arguments must be numbers, characters or markers.
1225 With one argument, reciprocates the argument.
1226 */
1227 (int nargs, Lisp_Object *args))
1228 {
1229 EMACS_INT iaccum;
1230 double daccum;
1231 Lisp_Object *args_end = args + nargs;
1232 int_or_double iod;
1233
1234 if (nargs == 1)
1235 iaccum = 1;
1236 else
1237 {
1238 number_char_or_marker_to_int_or_double (*args++, &iod);
1239 if (iod.int_p)
1240 iaccum = iod.c.ival;
1241 else
1242 {
1243 daccum = iod.c.dval;
1244 goto divide_floats;
1245 }
1246 }
1247
1248 while (args < args_end)
1249 {
1250 number_char_or_marker_to_int_or_double (*args++, &iod);
1251 if (iod.int_p)
1252 {
1253 if (iod.c.ival == 0) goto divide_by_zero;
1254 iaccum /= iod.c.ival;
1254 } 1255 }
1255 else 1256 else
1256 { 1257 {
1257 args[argnum] = val; /* runs into a compiler bug. */ 1258 if (iod.c.dval == 0) goto divide_by_zero;
1258 next = XINT (args[argnum]); 1259 daccum = (double) iaccum / iod.c.dval;
1260 goto divide_floats;
1259 } 1261 }
1260 switch (code) 1262 }
1263
1264 return make_int (iaccum);
1265
1266 divide_floats:
1267 for (; args < args_end; args++)
1268 {
1269 double dval = number_char_or_marker_to_double (*args);
1270 if (dval == 0) goto divide_by_zero;
1271 daccum /= dval;
1272 }
1273 return make_float (daccum);
1274
1275 divide_by_zero:
1276 Fsignal (Qarith_error, Qnil);
1277 return Qnil; /* not reached */
1278 }
1279
1280 DEFUN ("max", Fmax, 1, MANY, 0, /*
1281 Return largest of all the arguments.
1282 All arguments must be numbers, characters or markers.
1283 The value is always a number; markers and characters are converted
1284 to numbers.
1285 */
1286 (int nargs, Lisp_Object *args))
1287 {
1288 EMACS_INT imax;
1289 double dmax;
1290 Lisp_Object *args_end = args + nargs;
1291 int_or_double iod;
1292
1293 number_char_or_marker_to_int_or_double (*args++, &iod);
1294 if (iod.int_p)
1295 imax = iod.c.ival;
1296 else
1297 {
1298 dmax = iod.c.dval;
1299 goto max_floats;
1300 }
1301
1302 while (args < args_end)
1303 {
1304 number_char_or_marker_to_int_or_double (*args++, &iod);
1305 if (iod.int_p)
1261 { 1306 {
1262 case Aadd: 1307 if (imax < iod.c.ival) imax = iod.c.ival;
1263 accum += next;
1264 break;
1265 case Asub:
1266 if (!argnum && nargs != 1)
1267 next = - next;
1268 accum -= next;
1269 break;
1270 case Amult:
1271 accum *= next;
1272 break;
1273 case Adiv:
1274 if (!argnum)
1275 accum = next;
1276 else
1277 {
1278 if (next == 0)
1279 Fsignal (Qarith_error, Qnil);
1280 accum /= next;
1281 }
1282 break;
1283 case Alogand:
1284 case Alogior:
1285 case Alogxor:
1286 return wrong_type_argument (Qinteger_char_or_marker_p, val);
1287 case Amax:
1288 if (!argnum || isnan (next) || next > accum)
1289 accum = next;
1290 break;
1291 case Amin:
1292 if (!argnum || isnan (next) || next < accum)
1293 accum = next;
1294 break;
1295 } 1308 }
1296 } 1309 else
1297
1298 return make_float (accum);
1299 }
1300 #endif /* LISP_FLOAT_TYPE */
1301
1302 static Lisp_Object
1303 arith_driver (enum arithop code, int nargs, Lisp_Object *args)
1304 {
1305 Lisp_Object val;
1306 REGISTER int argnum;
1307 REGISTER EMACS_INT accum = 0;
1308 REGISTER EMACS_INT next;
1309
1310 switch (code)
1311 {
1312 case Alogior:
1313 case Alogxor:
1314 case Aadd:
1315 case Asub:
1316 accum = 0; break;
1317 case Amult:
1318 accum = 1; break;
1319 case Alogand:
1320 accum = -1; break;
1321 case Adiv:
1322 case Amax:
1323 case Amin:
1324 accum = 0; break;
1325 default:
1326 abort ();
1327 }
1328
1329 for (argnum = 0; argnum < nargs; argnum++)
1330 {
1331 /* using args[argnum] as argument to CHECK_INT_OR_FLOAT_... */
1332 val = args[argnum];
1333 CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (val);
1334
1335 #ifdef LISP_FLOAT_TYPE
1336 if (FLOATP (val)) /* time to do serious math */
1337 return float_arith_driver ((double) accum, argnum, code,
1338 nargs, args);
1339 #endif /* LISP_FLOAT_TYPE */
1340 args[argnum] = val; /* runs into a compiler bug. */
1341 next = XINT (args[argnum]);
1342 switch (code)
1343 { 1310 {
1344 case Aadd: accum += next; break; 1311 dmax = (double) imax;
1345 case Asub: 1312 if (dmax < iod.c.dval) dmax = iod.c.dval;
1346 if (!argnum && nargs != 1) 1313 goto max_floats;
1347 next = - next;
1348 accum -= next;
1349 break;
1350 case Amult: accum *= next; break;
1351 case Adiv:
1352 if (!argnum) accum = next;
1353 else
1354 {
1355 if (next == 0)
1356 Fsignal (Qarith_error, Qnil);
1357 accum /= next;
1358 }
1359 break;
1360 case Alogand: accum &= next; break;
1361 case Alogior: accum |= next; break;
1362 case Alogxor: accum ^= next; break;
1363 case Amax: if (!argnum || next > accum) accum = next; break;
1364 case Amin: if (!argnum || next < accum) accum = next; break;
1365 } 1314 }
1366 } 1315 }
1367 1316
1368 XSETINT (val, accum); 1317 return make_int (imax);
1369 return val; 1318
1370 } 1319 max_floats:
1371 1320 while (args < args_end)
1372 DEFUN ("+", Fplus, 0, MANY, 0, /* 1321 {
1373 Return sum of any number of arguments. 1322 double dval = number_char_or_marker_to_double (*args++);
1374 The arguments should all be numbers, characters or markers. 1323 if (dmax < dval) dmax = dval;
1324 }
1325 return make_float (dmax);
1326 }
1327
1328 DEFUN ("min", Fmin, 1, MANY, 0, /*
1329 Return smallest of all the arguments.
1330 All arguments must be numbers, characters or markers.
1331 The value is always a number; markers and characters are converted
1332 to numbers.
1375 */ 1333 */
1376 (int nargs, Lisp_Object *args)) 1334 (int nargs, Lisp_Object *args))
1377 { 1335 {
1378 return arith_driver (Aadd, nargs, args); 1336 EMACS_INT imin;
1379 } 1337 double dmin;
1380 1338 Lisp_Object *args_end = args + nargs;
1381 DEFUN ("-", Fminus, 0, MANY, 0, /* 1339 int_or_double iod;
1382 Negate number or subtract numbers, characters or markers. 1340
1383 With one arg, negates it. With more than one arg, 1341 number_char_or_marker_to_int_or_double (*args++, &iod);
1384 subtracts all but the first from the first. 1342 if (iod.int_p)
1343 imin = iod.c.ival;
1344 else
1345 {
1346 dmin = iod.c.dval;
1347 goto min_floats;
1348 }
1349
1350 while (args < args_end)
1351 {
1352 number_char_or_marker_to_int_or_double (*args++, &iod);
1353 if (iod.int_p)
1354 {
1355 if (imin > iod.c.ival) imin = iod.c.ival;
1356 }
1357 else
1358 {
1359 dmin = (double) imin;
1360 if (dmin > iod.c.dval) dmin = iod.c.dval;
1361 goto min_floats;
1362 }
1363 }
1364
1365 return make_int (imin);
1366
1367 min_floats:
1368 while (args < args_end)
1369 {
1370 double dval = number_char_or_marker_to_double (*args++);
1371 if (dmin > dval) dmin = dval;
1372 }
1373 return make_float (dmin);
1374 }
1375
1376 DEFUN ("logand", Flogand, 0, MANY, 0, /*
1377 Return bitwise-and of all the arguments.
1378 Arguments may be integers, or markers or characters converted to integers.
1385 */ 1379 */
1386 (int nargs, Lisp_Object *args)) 1380 (int nargs, Lisp_Object *args))
1387 { 1381 {
1388 return arith_driver (Asub, nargs, args); 1382 EMACS_INT bits = ~0;
1389 } 1383 Lisp_Object *args_end = args + nargs;
1390 1384
1391 DEFUN ("*", Ftimes, 0, MANY, 0, /* 1385 while (args < args_end)
1392 Return product of any number of arguments. 1386 bits &= integer_char_or_marker_to_int (*args++);
1393 The arguments should all be numbers, characters or markers. 1387
1388 return make_int (bits);
1389 }
1390
1391 DEFUN ("logior", Flogior, 0, MANY, 0, /*
1392 Return bitwise-or of all the arguments.
1393 Arguments may be integers, or markers or characters converted to integers.
1394 */ 1394 */
1395 (int nargs, Lisp_Object *args)) 1395 (int nargs, Lisp_Object *args))
1396 { 1396 {
1397 return arith_driver (Amult, nargs, args); 1397 EMACS_INT bits = 0;
1398 } 1398 Lisp_Object *args_end = args + nargs;
1399 1399
1400 DEFUN ("/", Fquo, 2, MANY, 0, /* 1400 while (args < args_end)
1401 Return first argument divided by all the remaining arguments. 1401 bits |= integer_char_or_marker_to_int (*args++);
1402 The arguments must be numbers, characters or markers. 1402
1403 return make_int (bits);
1404 }
1405
1406 DEFUN ("logxor", Flogxor, 0, MANY, 0, /*
1407 Return bitwise-exclusive-or of all the arguments.
1408 Arguments may be integers, or markers or characters converted to integers.
1403 */ 1409 */
1404 (int nargs, Lisp_Object *args)) 1410 (int nargs, Lisp_Object *args))
1405 { 1411 {
1406 return arith_driver (Adiv, nargs, args); 1412 EMACS_INT bits = 0;
1413 Lisp_Object *args_end = args + nargs;
1414
1415 while (args < args_end)
1416 bits ^= integer_char_or_marker_to_int (*args++);
1417
1418 return make_int (bits);
1419 }
1420
1421 DEFUN ("lognot", Flognot, 1, 1, 0, /*
1422 Return the bitwise complement of NUMBER.
1423 NUMBER may be an integer, marker or character converted to integer.
1424 */
1425 (number))
1426 {
1427 return make_int (~ integer_char_or_marker_to_int (number));
1407 } 1428 }
1408 1429
1409 DEFUN ("%", Frem, 2, 2, 0, /* 1430 DEFUN ("%", Frem, 2, 2, 0, /*
1410 Return remainder of first arg divided by second. 1431 Return remainder of first arg divided by second.
1411 Both must be integers, characters or markers. 1432 Both must be integers, characters or markers.
1412 */ 1433 */
1413 (num1, num2)) 1434 (num1, num2))
1414 { 1435 {
1415 CHECK_INT_COERCE_CHAR_OR_MARKER (num1); 1436 int ival1 = integer_char_or_marker_to_int (num1);
1416 CHECK_INT_COERCE_CHAR_OR_MARKER (num2); 1437 int ival2 = integer_char_or_marker_to_int (num2);
1417 1438
1418 if (ZEROP (num2)) 1439 if (ival2 == 0)
1419 Fsignal (Qarith_error, Qnil); 1440 Fsignal (Qarith_error, Qnil);
1420 1441
1421 return make_int (XINT (num1) % XINT (num2)); 1442 return make_int (ival1 % ival2);
1422 } 1443 }
1423 1444
1424 /* Note, ANSI *requires* the presence of the fmod() library routine. 1445 /* Note, ANSI *requires* the presence of the fmod() library routine.
1425 If your system doesn't have it, complain to your vendor, because 1446 If your system doesn't have it, complain to your vendor, because
1426 that is a bug. */ 1447 that is a bug. */
1442 Both X and Y must be numbers, characters or markers. 1463 Both X and Y must be numbers, characters or markers.
1443 If either argument is a float, a float will be returned. 1464 If either argument is a float, a float will be returned.
1444 */ 1465 */
1445 (x, y)) 1466 (x, y))
1446 { 1467 {
1447 EMACS_INT i1, i2; 1468 int_or_double iod1, iod2;
1469 number_char_or_marker_to_int_or_double (x, &iod1);
1470 number_char_or_marker_to_int_or_double (y, &iod2);
1448 1471
1449 #ifdef LISP_FLOAT_TYPE 1472 #ifdef LISP_FLOAT_TYPE
1450 CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (x); 1473 if (!iod1.int_p || !iod2.int_p)
1451 CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (y); 1474 {
1452 1475 double dval1 = iod1.int_p ? (double) iod1.c.ival : iod1.c.dval;
1453 if (FLOATP (x) || FLOATP (y)) 1476 double dval2 = iod2.int_p ? (double) iod2.c.ival : iod2.c.dval;
1454 { 1477 if (dval2 == 0) goto divide_by_zero;
1455 double f1, f2; 1478 dval1 = fmod (dval1, dval2);
1456
1457 f1 = ((FLOATP (x)) ? float_data (XFLOAT (x)) : XINT (x));
1458 f2 = ((FLOATP (y)) ? float_data (XFLOAT (y)) : XINT (y));
1459 if (f2 == 0)
1460 Fsignal (Qarith_error, Qnil);
1461
1462 f1 = fmod (f1, f2);
1463 1479
1464 /* If the "remainder" comes out with the wrong sign, fix it. */ 1480 /* If the "remainder" comes out with the wrong sign, fix it. */
1465 if (f2 < 0 ? f1 > 0 : f1 < 0) 1481 if (dval2 < 0 ? dval1 > 0 : dval1 < 0)
1466 f1 += f2; 1482 dval1 += dval2;
1467 return make_float (f1); 1483
1468 } 1484 return make_float (dval1);
1469 #else /* not LISP_FLOAT_TYPE */ 1485 }
1470 CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (x); 1486 #endif /* LISP_FLOAT_TYPE */
1471 CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (y); 1487 {
1472 #endif /* not LISP_FLOAT_TYPE */ 1488 int ival;
1473 1489 if (iod2.c.ival == 0) goto divide_by_zero;
1474 i1 = XINT (x); 1490
1475 i2 = XINT (y); 1491 ival = iod1.c.ival % iod2.c.ival;
1476 1492
1477 if (i2 == 0) 1493 /* If the "remainder" comes out with the wrong sign, fix it. */
1478 Fsignal (Qarith_error, Qnil); 1494 if (iod2.c.ival < 0 ? ival > 0 : ival < 0)
1479 1495 ival += iod2.c.ival;
1480 i1 %= i2; 1496
1481 1497 return make_int (ival);
1482 /* If the "remainder" comes out with the wrong sign, fix it. */ 1498 }
1483 if (i2 < 0 ? i1 > 0 : i1 < 0) 1499
1484 i1 += i2; 1500 divide_by_zero:
1485 1501 Fsignal (Qarith_error, Qnil);
1486 return make_int (i1); 1502 return Qnil; /* not reached */
1487 }
1488
1489
1490 DEFUN ("max", Fmax, 1, MANY, 0, /*
1491 Return largest of all the arguments.
1492 All arguments must be numbers, characters or markers.
1493 The value is always a number; markers and characters are converted
1494 to numbers.
1495 */
1496 (int nargs, Lisp_Object *args))
1497 {
1498 return arith_driver (Amax, nargs, args);
1499 }
1500
1501 DEFUN ("min", Fmin, 1, MANY, 0, /*
1502 Return smallest of all the arguments.
1503 All arguments must be numbers, characters or markers.
1504 The value is always a number; markers and characters are converted
1505 to numbers.
1506 */
1507 (int nargs, Lisp_Object *args))
1508 {
1509 return arith_driver (Amin, nargs, args);
1510 }
1511
1512 DEFUN ("logand", Flogand, 0, MANY, 0, /*
1513 Return bitwise-and of all the arguments.
1514 Arguments may be integers, or markers or characters converted to integers.
1515 */
1516 (int nargs, Lisp_Object *args))
1517 {
1518 return arith_driver (Alogand, nargs, args);
1519 }
1520
1521 DEFUN ("logior", Flogior, 0, MANY, 0, /*
1522 Return bitwise-or of all the arguments.
1523 Arguments may be integers, or markers or characters converted to integers.
1524 */
1525 (int nargs, Lisp_Object *args))
1526 {
1527 return arith_driver (Alogior, nargs, args);
1528 }
1529
1530 DEFUN ("logxor", Flogxor, 0, MANY, 0, /*
1531 Return bitwise-exclusive-or of all the arguments.
1532 Arguments may be integers, or markers or characters converted to integers.
1533 */
1534 (int nargs, Lisp_Object *args))
1535 {
1536 return arith_driver (Alogxor, nargs, args);
1537 } 1503 }
1538 1504
1539 DEFUN ("ash", Fash, 2, 2, 0, /* 1505 DEFUN ("ash", Fash, 2, 2, 0, /*
1540 Return VALUE with its bits shifted left by COUNT. 1506 Return VALUE with its bits shifted left by COUNT.
1541 If COUNT is negative, shifting is actually to the right. 1507 If COUNT is negative, shifting is actually to the right.
1542 In this case, the sign bit is duplicated. 1508 In this case, the sign bit is duplicated.
1543 */ 1509 */
1544 (value, count)) 1510 (value, count))
1545 { 1511 {
1546 CHECK_INT_COERCE_CHAR (value); 1512 CHECK_INT_COERCE_CHAR (value);
1547 CHECK_INT (count); 1513 CONCHECK_INT (count);
1548 1514
1549 return make_int (XINT (count) > 0 ? 1515 return make_int (XINT (count) > 0 ?
1550 XINT (value) << XINT (count) : 1516 XINT (value) << XINT (count) :
1551 XINT (value) >> -XINT (count)); 1517 XINT (value) >> -XINT (count));
1552 } 1518 }
1557 In this case, zeros are shifted in on the left. 1523 In this case, zeros are shifted in on the left.
1558 */ 1524 */
1559 (value, count)) 1525 (value, count))
1560 { 1526 {
1561 CHECK_INT_COERCE_CHAR (value); 1527 CHECK_INT_COERCE_CHAR (value);
1562 CHECK_INT (count); 1528 CONCHECK_INT (count);
1563 1529
1564 return make_int (XINT (count) > 0 ? 1530 return make_int (XINT (count) > 0 ?
1565 XUINT (value) << XINT (count) : 1531 XUINT (value) << XINT (count) :
1566 XUINT (value) >> -XINT (count)); 1532 XUINT (value) >> -XINT (count));
1567 } 1533 }
1568 1534
1569 DEFUN ("1+", Fadd1, 1, 1, 0, /* 1535 DEFUN ("1+", Fadd1, 1, 1, 0, /*
1570 Return NUMBER plus one. NUMBER may be a number or a marker. 1536 Return NUMBER plus one. NUMBER may be a number, character or marker.
1571 Markers and characters are converted to integers. 1537 Markers and characters are converted to integers.
1572 */ 1538 */
1573 (number)) 1539 (number))
1574 { 1540 {
1575 CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (number); 1541 retry:
1576 1542
1543 if (INTP (number)) return make_int (XINT (number) + 1);
1544 if (CHARP (number)) return make_int (XCHAR (number) + 1);
1545 if (MARKERP (number)) return make_int (marker_position (number) + 1);
1577 #ifdef LISP_FLOAT_TYPE 1546 #ifdef LISP_FLOAT_TYPE
1578 if (FLOATP (number)) 1547 if (FLOATP (number)) return make_float (XFLOAT_DATA (number) + 1.0);
1579 return make_float (1.0 + float_data (XFLOAT (number)));
1580 #endif /* LISP_FLOAT_TYPE */ 1548 #endif /* LISP_FLOAT_TYPE */
1581 1549
1582 return make_int (XINT (number) + 1); 1550 number = wrong_type_argument (Qnumber_char_or_marker_p, number);
1551 goto retry;
1583 } 1552 }
1584 1553
1585 DEFUN ("1-", Fsub1, 1, 1, 0, /* 1554 DEFUN ("1-", Fsub1, 1, 1, 0, /*
1586 Return NUMBER minus one. NUMBER may be a number or a marker. 1555 Return NUMBER minus one. NUMBER may be a number, character or marker.
1587 Markers and characters are converted to integers. 1556 Markers and characters are converted to integers.
1588 */ 1557 */
1589 (number)) 1558 (number))
1590 { 1559 {
1591 CHECK_INT_OR_FLOAT_COERCE_CHAR_OR_MARKER (number); 1560 retry:
1592 1561
1562 if (INTP (number)) return make_int (XINT (number) - 1);
1563 if (CHARP (number)) return make_int (XCHAR (number) - 1);
1564 if (MARKERP (number)) return make_int (marker_position (number) - 1);
1593 #ifdef LISP_FLOAT_TYPE 1565 #ifdef LISP_FLOAT_TYPE
1594 if (FLOATP (number)) 1566 if (FLOATP (number)) return make_float (XFLOAT_DATA (number) - 1.0);
1595 return make_float (-1.0 + (float_data (XFLOAT (number))));
1596 #endif /* LISP_FLOAT_TYPE */ 1567 #endif /* LISP_FLOAT_TYPE */
1597 1568
1598 return make_int (XINT (number) - 1); 1569 number = wrong_type_argument (Qnumber_char_or_marker_p, number);
1599 } 1570 goto retry;
1600
1601 DEFUN ("lognot", Flognot, 1, 1, 0, /*
1602 Return the bitwise complement of NUMBER. NUMBER must be an integer.
1603 */
1604 (number))
1605 {
1606 CHECK_INT (number);
1607 return make_int (~XINT (number));
1608 } 1571 }
1609 1572
1610 1573
1611 /************************************************************************/ 1574 /************************************************************************/
1612 /* weak lists */ 1575 /* weak lists */
1614 1577
1615 /* A weak list is like a normal list except that elements automatically 1578 /* A weak list is like a normal list except that elements automatically
1616 disappear when no longer in use, i.e. when no longer GC-protected. 1579 disappear when no longer in use, i.e. when no longer GC-protected.
1617 The basic idea is that we don't mark the elements during GC, but 1580 The basic idea is that we don't mark the elements during GC, but
1618 wait for them to be marked elsewhere. If they're not marked, we 1581 wait for them to be marked elsewhere. If they're not marked, we
1619 remove them. This is analogous to weak hashtables; see the explanation 1582 remove them. This is analogous to weak hash tables; see the explanation
1620 there for more info. */ 1583 there for more info. */
1621 1584
1622 static Lisp_Object Vall_weak_lists; /* Gemarke es nicht!!! */ 1585 static Lisp_Object Vall_weak_lists; /* Gemarke es nicht!!! */
1623 1586
1624 static Lisp_Object encode_weak_list_type (enum weak_list_type type); 1587 static Lisp_Object encode_weak_list_type (enum weak_list_type type);
1642 print_internal (XWEAK_LIST (obj)->list, printcharfun, escapeflag); 1605 print_internal (XWEAK_LIST (obj)->list, printcharfun, escapeflag);
1643 write_c_string (">", printcharfun); 1606 write_c_string (">", printcharfun);
1644 } 1607 }
1645 1608
1646 static int 1609 static int
1647 weak_list_equal (Lisp_Object o1, Lisp_Object o2, int depth) 1610 weak_list_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
1648 { 1611 {
1649 struct weak_list *w1 = XWEAK_LIST (o1); 1612 struct weak_list *w1 = XWEAK_LIST (obj1);
1650 struct weak_list *w2 = XWEAK_LIST (o2); 1613 struct weak_list *w2 = XWEAK_LIST (obj2);
1651 1614
1652 return ((w1->type == w2->type) && 1615 return ((w1->type == w2->type) &&
1653 internal_equal (w1->list, w2->list, depth + 1)); 1616 internal_equal (w1->list, w2->list, depth + 1));
1654 } 1617 }
1655 1618
1710 rest = XWEAK_LIST (rest)->next_weak) 1673 rest = XWEAK_LIST (rest)->next_weak)
1711 { 1674 {
1712 Lisp_Object rest2; 1675 Lisp_Object rest2;
1713 enum weak_list_type type = XWEAK_LIST (rest)->type; 1676 enum weak_list_type type = XWEAK_LIST (rest)->type;
1714 1677
1715 if (! ((*obj_marked_p) (rest))) 1678 if (! obj_marked_p (rest))
1716 /* The weak list is probably garbage. Ignore it. */ 1679 /* The weak list is probably garbage. Ignore it. */
1717 continue; 1680 continue;
1718 1681
1719 for (rest2 = XWEAK_LIST (rest)->list; 1682 for (rest2 = XWEAK_LIST (rest)->list;
1720 /* We need to be trickier since we're inside of GC; 1683 /* We need to be trickier since we're inside of GC;
1733 1696
1734 /* If a cons is already marked, then its car is already marked 1697 /* If a cons is already marked, then its car is already marked
1735 (either because of an external pointer or because of 1698 (either because of an external pointer or because of
1736 a previous call to this function), and likewise for all 1699 a previous call to this function), and likewise for all
1737 the rest of the elements in the list, so we can stop now. */ 1700 the rest of the elements in the list, so we can stop now. */
1738 if ((*obj_marked_p) (rest2)) 1701 if (obj_marked_p (rest2))
1739 break; 1702 break;
1740 1703
1741 elem = XCAR (rest2); 1704 elem = XCAR (rest2);
1742 1705
1743 switch (type) 1706 switch (type)
1744 { 1707 {
1745 case WEAK_LIST_SIMPLE: 1708 case WEAK_LIST_SIMPLE:
1746 if ((*obj_marked_p) (elem)) 1709 if (obj_marked_p (elem))
1747 need_to_mark_cons = 1; 1710 need_to_mark_cons = 1;
1748 break; 1711 break;
1749 1712
1750 case WEAK_LIST_ASSOC: 1713 case WEAK_LIST_ASSOC:
1751 if (!GC_CONSP (elem)) 1714 if (!GC_CONSP (elem))
1752 { 1715 {
1753 /* just leave bogus elements there */ 1716 /* just leave bogus elements there */
1754 need_to_mark_cons = 1; 1717 need_to_mark_cons = 1;
1755 need_to_mark_elem = 1; 1718 need_to_mark_elem = 1;
1756 } 1719 }
1757 else if ((*obj_marked_p) (XCAR (elem)) && 1720 else if (obj_marked_p (XCAR (elem)) &&
1758 (*obj_marked_p) (XCDR (elem))) 1721 obj_marked_p (XCDR (elem)))
1759 { 1722 {
1760 need_to_mark_cons = 1; 1723 need_to_mark_cons = 1;
1761 /* We still need to mark elem, because it's 1724 /* We still need to mark elem, because it's
1762 probably not marked. */ 1725 probably not marked. */
1763 need_to_mark_elem = 1; 1726 need_to_mark_elem = 1;
1769 { 1732 {
1770 /* just leave bogus elements there */ 1733 /* just leave bogus elements there */
1771 need_to_mark_cons = 1; 1734 need_to_mark_cons = 1;
1772 need_to_mark_elem = 1; 1735 need_to_mark_elem = 1;
1773 } 1736 }
1774 else if ((*obj_marked_p) (XCAR (elem))) 1737 else if (obj_marked_p (XCAR (elem)))
1775 { 1738 {
1776 need_to_mark_cons = 1; 1739 need_to_mark_cons = 1;
1777 /* We still need to mark elem and XCDR (elem); 1740 /* We still need to mark elem and XCDR (elem);
1778 marking elem does both */ 1741 marking elem does both */
1779 need_to_mark_elem = 1; 1742 need_to_mark_elem = 1;
1785 { 1748 {
1786 /* just leave bogus elements there */ 1749 /* just leave bogus elements there */
1787 need_to_mark_cons = 1; 1750 need_to_mark_cons = 1;
1788 need_to_mark_elem = 1; 1751 need_to_mark_elem = 1;
1789 } 1752 }
1790 else if ((*obj_marked_p) (XCDR (elem))) 1753 else if (obj_marked_p (XCDR (elem)))
1791 { 1754 {
1792 need_to_mark_cons = 1; 1755 need_to_mark_cons = 1;
1793 /* We still need to mark elem and XCAR (elem); 1756 /* We still need to mark elem and XCAR (elem);
1794 marking elem does both */ 1757 marking elem does both */
1795 need_to_mark_elem = 1; 1758 need_to_mark_elem = 1;
1798 1761
1799 default: 1762 default:
1800 abort (); 1763 abort ();
1801 } 1764 }
1802 1765
1803 if (need_to_mark_elem && ! (*obj_marked_p) (elem)) 1766 if (need_to_mark_elem && ! obj_marked_p (elem))
1804 { 1767 {
1805 (*markobj) (elem); 1768 markobj (elem);
1806 did_mark = 1; 1769 did_mark = 1;
1807 } 1770 }
1808 1771
1809 /* We also need to mark the cons that holds the elem or 1772 /* We also need to mark the cons that holds the elem or
1810 assoc-pair. We do *not* want to call (markobj) here 1773 assoc-pair. We do *not* want to call (markobj) here
1822 } 1785 }
1823 } 1786 }
1824 1787
1825 /* In case of imperfect list, need to mark the final cons 1788 /* In case of imperfect list, need to mark the final cons
1826 because we're not removing it */ 1789 because we're not removing it */
1827 if (!GC_NILP (rest2) && ! (obj_marked_p) (rest2)) 1790 if (!GC_NILP (rest2) && ! obj_marked_p (rest2))
1828 { 1791 {
1829 (markobj) (rest2); 1792 markobj (rest2);
1830 did_mark = 1; 1793 did_mark = 1;
1831 } 1794 }
1832 } 1795 }
1833 1796
1834 return did_mark; 1797 return did_mark;
1841 1804
1842 for (rest = Vall_weak_lists; 1805 for (rest = Vall_weak_lists;
1843 !GC_NILP (rest); 1806 !GC_NILP (rest);
1844 rest = XWEAK_LIST (rest)->next_weak) 1807 rest = XWEAK_LIST (rest)->next_weak)
1845 { 1808 {
1846 if (! ((*obj_marked_p) (rest))) 1809 if (! (obj_marked_p (rest)))
1847 { 1810 {
1848 /* This weak list itself is garbage. Remove it from the list. */ 1811 /* This weak list itself is garbage. Remove it from the list. */
1849 if (GC_NILP (prev)) 1812 if (GC_NILP (prev))
1850 Vall_weak_lists = XWEAK_LIST (rest)->next_weak; 1813 Vall_weak_lists = XWEAK_LIST (rest)->next_weak;
1851 else 1814 else
1871 then it should stay around and will be marked. 1834 then it should stay around and will be marked.
1872 -- otherwise, if it should stay around, it will 1835 -- otherwise, if it should stay around, it will
1873 have been marked in finish_marking_weak_lists(). 1836 have been marked in finish_marking_weak_lists().
1874 -- otherwise, it's not marked and should disappear. 1837 -- otherwise, it's not marked and should disappear.
1875 */ 1838 */
1876 if (!(*obj_marked_p) (rest2)) 1839 if (! obj_marked_p (rest2))
1877 { 1840 {
1878 /* bye bye :-( */ 1841 /* bye bye :-( */
1879 if (GC_NILP (prev2)) 1842 if (GC_NILP (prev2))
1880 XWEAK_LIST (rest)->list = XCDR (rest2); 1843 XWEAK_LIST (rest)->list = XCDR (rest2);
1881 else 1844 else
2084 "Symbol's chain of variable indirections contains a loop", Qerror); 2047 "Symbol's chain of variable indirections contains a loop", Qerror);
2085 deferror (&Qsetting_constant, "setting-constant", 2048 deferror (&Qsetting_constant, "setting-constant",
2086 "Attempt to set a constant symbol", Qerror); 2049 "Attempt to set a constant symbol", Qerror);
2087 deferror (&Qinvalid_read_syntax, "invalid-read-syntax", 2050 deferror (&Qinvalid_read_syntax, "invalid-read-syntax",
2088 "Invalid read syntax", Qerror); 2051 "Invalid read syntax", Qerror);
2052
2053 /* Generated by list traversal macros */
2089 deferror (&Qmalformed_list, "malformed-list", 2054 deferror (&Qmalformed_list, "malformed-list",
2090 "Malformed list", Qerror); 2055 "Malformed list", Qerror);
2091 deferror (&Qmalformed_property_list, "malformed-property-list", 2056 deferror (&Qmalformed_property_list, "malformed-property-list",
2092 "Malformed property list", Qerror); 2057 "Malformed property list", Qmalformed_list);
2093 deferror (&Qcircular_list, "circular-list", 2058 deferror (&Qcircular_list, "circular-list",
2094 "Circular list", Qerror); 2059 "Circular list", Qerror);
2095 deferror (&Qcircular_property_list, "circular-property-list", 2060 deferror (&Qcircular_property_list, "circular-property-list",
2096 "Circular property list", Qerror); 2061 "Circular property list", Qcircular_list);
2062
2097 deferror (&Qinvalid_function, "invalid-function", "Invalid function", 2063 deferror (&Qinvalid_function, "invalid-function", "Invalid function",
2098 Qerror); 2064 Qerror);
2099 deferror (&Qwrong_number_of_arguments, "wrong-number-of-arguments", 2065 deferror (&Qwrong_number_of_arguments, "wrong-number-of-arguments",
2100 "Wrong number of arguments", Qerror); 2066 "Wrong number of arguments", Qerror);
2101 deferror (&Qno_catch, "no-catch", "No catch for tag", 2067 deferror (&Qno_catch, "no-catch", "No catch for tag",
2144 defsymbol (&Qsequencep, "sequencep"); 2110 defsymbol (&Qsequencep, "sequencep");
2145 defsymbol (&Qbufferp, "bufferp"); 2111 defsymbol (&Qbufferp, "bufferp");
2146 defsymbol (&Qbitp, "bitp"); 2112 defsymbol (&Qbitp, "bitp");
2147 defsymbol (&Qbit_vectorp, "bit-vector-p"); 2113 defsymbol (&Qbit_vectorp, "bit-vector-p");
2148 defsymbol (&Qvectorp, "vectorp"); 2114 defsymbol (&Qvectorp, "vectorp");
2149 defsymbol (&Qcompiled_functionp, "compiled-function-p");
2150 defsymbol (&Qchar_or_string_p, "char-or-string-p"); 2115 defsymbol (&Qchar_or_string_p, "char-or-string-p");
2151 defsymbol (&Qmarkerp, "markerp"); 2116 defsymbol (&Qmarkerp, "markerp");
2152 defsymbol (&Qinteger_or_marker_p, "integer-or-marker-p"); 2117 defsymbol (&Qinteger_or_marker_p, "integer-or-marker-p");
2153 defsymbol (&Qinteger_or_char_p, "integer-or-char-p"); 2118 defsymbol (&Qinteger_or_char_p, "integer-or-char-p");
2154 defsymbol (&Qinteger_char_or_marker_p, "integer-char-or-marker-p"); 2119 defsymbol (&Qinteger_char_or_marker_p, "integer-char-or-marker-p");
2165 DEFSUBR (Fwrong_type_argument); 2130 DEFSUBR (Fwrong_type_argument);
2166 2131
2167 DEFSUBR (Feq); 2132 DEFSUBR (Feq);
2168 DEFSUBR (Fold_eq); 2133 DEFSUBR (Fold_eq);
2169 DEFSUBR (Fnull); 2134 DEFSUBR (Fnull);
2135 Ffset (intern ("not"), intern ("null"));
2170 DEFSUBR (Flistp); 2136 DEFSUBR (Flistp);
2171 DEFSUBR (Fnlistp); 2137 DEFSUBR (Fnlistp);
2172 DEFSUBR (Ftrue_list_p); 2138 DEFSUBR (Ftrue_list_p);
2173 DEFSUBR (Fconsp); 2139 DEFSUBR (Fconsp);
2174 DEFSUBR (Fatom); 2140 DEFSUBR (Fatom);
2200 DEFSUBR (Fmarkerp); 2166 DEFSUBR (Fmarkerp);
2201 DEFSUBR (Fsubrp); 2167 DEFSUBR (Fsubrp);
2202 DEFSUBR (Fsubr_min_args); 2168 DEFSUBR (Fsubr_min_args);
2203 DEFSUBR (Fsubr_max_args); 2169 DEFSUBR (Fsubr_max_args);
2204 DEFSUBR (Fsubr_interactive); 2170 DEFSUBR (Fsubr_interactive);
2205 DEFSUBR (Fcompiled_function_p);
2206 DEFSUBR (Ftype_of); 2171 DEFSUBR (Ftype_of);
2207 DEFSUBR (Fcar); 2172 DEFSUBR (Fcar);
2208 DEFSUBR (Fcdr); 2173 DEFSUBR (Fcdr);
2209 DEFSUBR (Fcar_safe); 2174 DEFSUBR (Fcar_safe);
2210 DEFSUBR (Fcdr_safe); 2175 DEFSUBR (Fcdr_safe);
2211 DEFSUBR (Fsetcar); 2176 DEFSUBR (Fsetcar);
2212 DEFSUBR (Fsetcdr); 2177 DEFSUBR (Fsetcdr);
2213 DEFSUBR (Findirect_function); 2178 DEFSUBR (Findirect_function);
2214 DEFSUBR (Faref); 2179 DEFSUBR (Faref);
2215 DEFSUBR (Faset); 2180 DEFSUBR (Faset);
2216
2217 DEFSUBR (Fcompiled_function_instructions);
2218 DEFSUBR (Fcompiled_function_constants);
2219 DEFSUBR (Fcompiled_function_stack_depth);
2220 DEFSUBR (Fcompiled_function_arglist);
2221 DEFSUBR (Fcompiled_function_interactive);
2222 DEFSUBR (Fcompiled_function_doc_string);
2223 DEFSUBR (Fcompiled_function_domain);
2224 #ifdef COMPILED_FUNCTION_ANNOTATION_HACK
2225 DEFSUBR (Fcompiled_function_annotation);
2226 #endif
2227 2181
2228 DEFSUBR (Fnumber_to_string); 2182 DEFSUBR (Fnumber_to_string);
2229 DEFSUBR (Fstring_to_number); 2183 DEFSUBR (Fstring_to_number);
2230 DEFSUBR (Feqlsign); 2184 DEFSUBR (Feqlsign);
2231 DEFSUBR (Flss); 2185 DEFSUBR (Flss);
2264 /* This must not be staticpro'd */ 2218 /* This must not be staticpro'd */
2265 Vall_weak_lists = Qnil; 2219 Vall_weak_lists = Qnil;
2266 2220
2267 #ifdef DEBUG_XEMACS 2221 #ifdef DEBUG_XEMACS
2268 DEFVAR_INT ("debug-issue-ebola-notices", &debug_issue_ebola_notices /* 2222 DEFVAR_INT ("debug-issue-ebola-notices", &debug_issue_ebola_notices /*
2269 If non-nil, note when your code may be suffering from char-int confoundance. 2223 If non-zero, note when your code may be suffering from char-int confoundance.
2270 That is to say, if XEmacs encounters a usage of `eq', `memq', `equal', 2224 That is to say, if XEmacs encounters a usage of `eq', `memq', `equal',
2271 etc. where a int and a char with the same value are being compared, 2225 etc. where an int and a char with the same value are being compared,
2272 it will issue a notice on stderr to this effect, along with a backtrace. 2226 it will issue a notice on stderr to this effect, along with a backtrace.
2273 In such situations, the result would be different in XEmacs 19 versus 2227 In such situations, the result would be different in XEmacs 19 versus
2274 XEmacs 20, and you probably don't want this. 2228 XEmacs 20, and you probably don't want this.
2275 2229
2276 Note that in order to see these notices, you have to byte compile your 2230 Note that in order to see these notices, you have to byte compile your