annotate src/data.c @ 2010:a9cdbfb4716e

[xemacs-hg @ 2004-04-13 15:38:30 by james] Handle leading + signs on numbers correctly.
author james
date Tue, 13 Apr 2004 15:38:42 +0000
parents cc5b615380f8
children f2fdfc131770
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1 /* Primitive operations on Lisp data types for XEmacs Lisp interpreter.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2 Copyright (C) 1985, 1986, 1988, 1992, 1993, 1994, 1995
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3 Free Software Foundation, Inc.
1330
4542b72c005e [xemacs-hg @ 2003-03-01 07:25:26 by ben]
ben
parents: 1204
diff changeset
4 Copyright (C) 2000, 2001, 2002, 2003 Ben Wing.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
5
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
6 This file is part of XEmacs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
7
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
8 XEmacs is free software; you can redistribute it and/or modify it
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
9 under the terms of the GNU General Public License as published by the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
10 Free Software Foundation; either version 2, or (at your option) any
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
11 later version.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
12
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
13 XEmacs is distributed in the hope that it will be useful, but WITHOUT
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
14 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
16 for more details.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
17
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
18 You should have received a copy of the GNU General Public License
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
19 along with XEmacs; see the file COPYING. If not, write to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
20 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
21 Boston, MA 02111-1307, USA. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
22
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
23 /* Synched up with: Mule 2.0, FSF 19.30. Some of FSF's data.c is in
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
24 XEmacs' symbols.c. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
25
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
26 /* This file has been Mule-ized. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
27
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
28 #include <config.h>
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
29 #include "lisp.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
30
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
31 #include "buffer.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
32 #include "bytecode.h"
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
33 #include "syssignal.h"
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 665
diff changeset
34 #include "sysfloat.h"
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
35
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
36 Lisp_Object Qnil, Qt, Qquote, Qlambda, Qunbound;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
37 Lisp_Object Qerror_conditions, Qerror_message;
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
38 Lisp_Object Qerror, Qquit, Qsyntax_error, Qinvalid_read_syntax;
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 458
diff changeset
39 Lisp_Object Qlist_formation_error, Qstructure_formation_error;
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
40 Lisp_Object Qmalformed_list, Qmalformed_property_list;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
41 Lisp_Object Qcircular_list, Qcircular_property_list;
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 458
diff changeset
42 Lisp_Object Qinvalid_argument, Qinvalid_constant, Qwrong_type_argument;
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 458
diff changeset
43 Lisp_Object Qargs_out_of_range;
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
44 Lisp_Object Qwrong_number_of_arguments, Qinvalid_function, Qno_catch;
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 458
diff changeset
45 Lisp_Object Qinternal_error, Qinvalid_state, Qstack_overflow, Qout_of_memory;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
46 Lisp_Object Qvoid_variable, Qcyclic_variable_indirection;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
47 Lisp_Object Qvoid_function, Qcyclic_function_indirection;
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 458
diff changeset
48 Lisp_Object Qinvalid_operation, Qinvalid_change, Qprinting_unreadable_object;
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
49 Lisp_Object Qsetting_constant;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
50 Lisp_Object Qediting_error;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
51 Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only;
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 458
diff changeset
52 Lisp_Object Qio_error, Qfile_error, Qconversion_error, Qend_of_file;
580
55e998c311f5 [xemacs-hg @ 2001-05-26 12:24:50 by ben]
ben
parents: 563
diff changeset
53 Lisp_Object Qtext_conversion_error;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
54 Lisp_Object Qarith_error, Qrange_error, Qdomain_error;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
55 Lisp_Object Qsingularity_error, Qoverflow_error, Qunderflow_error;
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
56 Lisp_Object Qintegerp, Qnatnump, Qnonnegativep, Qsymbolp;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
57 Lisp_Object Qlistp, Qtrue_list_p, Qweak_listp;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
58 Lisp_Object Qconsp, Qsubrp;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
59 Lisp_Object Qcharacterp, Qstringp, Qarrayp, Qsequencep, Qvectorp;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
60 Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qbufferp;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
61 Lisp_Object Qinteger_or_char_p, Qinteger_char_or_marker_p;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
62 Lisp_Object Qnumberp, Qnumber_char_or_marker_p;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
63 Lisp_Object Qbit_vectorp, Qbitp, Qcdr;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
64
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 458
diff changeset
65 Lisp_Object Qerror_lacks_explanatory_string;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
66 Lisp_Object Qfloatp;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
67
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
68 #ifdef DEBUG_XEMACS
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
69
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
70 int debug_issue_ebola_notices;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
71
458
c33ae14dd6d0 Import from CVS: tag r21-2-44
cvs
parents: 456
diff changeset
72 Fixnum debug_ebola_backtrace_length;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
73
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
74 int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
75 eq_with_ebola_notice (Lisp_Object obj1, Lisp_Object obj2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
76 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
77 if (debug_issue_ebola_notices
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
78 && ((CHARP (obj1) && INTP (obj2)) || (CHARP (obj2) && INTP (obj1))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
79 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
80 /* #### It would be really nice if this were a proper warning
1551
ddcdeb1a25c4 [xemacs-hg @ 2003-06-30 09:45:42 by stephent]
stephent
parents: 1330
diff changeset
81 instead of brain-dead print to Qexternal_debugging_output. */
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 801
diff changeset
82 write_c_string
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 801
diff changeset
83 (Qexternal_debugging_output,
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 801
diff changeset
84 "Comparison between integer and character is constant nil (");
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
85 Fprinc (obj1, Qexternal_debugging_output);
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 801
diff changeset
86 write_c_string (Qexternal_debugging_output, " and ");
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
87 Fprinc (obj2, Qexternal_debugging_output);
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 801
diff changeset
88 write_c_string (Qexternal_debugging_output, ")\n");
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
89 debug_short_backtrace (debug_ebola_backtrace_length);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
90 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
91 return EQ (obj1, obj2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
92 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
93
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
94 #endif /* DEBUG_XEMACS */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
95
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
96
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
97
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
98 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
99 wrong_type_argument (Lisp_Object predicate, Lisp_Object value)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
100 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
101 /* This function can GC */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
102 REGISTER Lisp_Object tem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
103 do
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
104 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
105 value = Fsignal (Qwrong_type_argument, list2 (predicate, value));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
106 tem = call1 (predicate, value);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
107 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
108 while (NILP (tem));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
109 return value;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
110 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
111
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
112 DOESNT_RETURN
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
113 dead_wrong_type_argument (Lisp_Object predicate, Lisp_Object value)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
114 {
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 458
diff changeset
115 signal_error_1 (Qwrong_type_argument, list2 (predicate, value));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
116 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
117
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
118 DEFUN ("wrong-type-argument", Fwrong_type_argument, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
119 Signal an error until the correct type value is given by the user.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
120 This function loops, signalling a continuable `wrong-type-argument' error
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
121 with PREDICATE and VALUE as the data associated with the error and then
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
122 calling PREDICATE on the returned value, until the value gotten satisfies
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
123 PREDICATE. At that point, the gotten value is returned.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
124 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
125 (predicate, value))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
126 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
127 return wrong_type_argument (predicate, value);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
128 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
129
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
130 DOESNT_RETURN
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
131 c_write_error (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
132 {
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 458
diff changeset
133 signal_error (Qsetting_constant,
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 458
diff changeset
134 "Attempt to modify read-only object (c)", obj);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
135 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
136
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
137 DOESNT_RETURN
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
138 lisp_write_error (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
139 {
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 458
diff changeset
140 signal_error (Qsetting_constant,
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 458
diff changeset
141 "Attempt to modify read-only object (lisp)", obj);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
142 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
143
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
144 DOESNT_RETURN
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
145 args_out_of_range (Lisp_Object a1, Lisp_Object a2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
146 {
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 458
diff changeset
147 signal_error_1 (Qargs_out_of_range, list2 (a1, a2));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
148 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
149
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
150 DOESNT_RETURN
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
151 args_out_of_range_3 (Lisp_Object a1, Lisp_Object a2, Lisp_Object a3)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
152 {
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 458
diff changeset
153 signal_error_1 (Qargs_out_of_range, list3 (a1, a2, a3));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
154 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
155
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
156 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
157 check_int_range (EMACS_INT val, EMACS_INT min, EMACS_INT max)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
158 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
159 if (val < min || val > max)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
160 args_out_of_range_3 (make_int (val), make_int (min), make_int (max));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
161 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
162
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
163 /* On some machines, XINT needs a temporary location.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
164 Here it is, in case it is needed. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
165
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
166 EMACS_INT sign_extend_temp;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
167
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
168 /* On a few machines, XINT can only be done by calling this. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
169 /* XEmacs: only used by m/convex.h */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
170 EMACS_INT sign_extend_lisp_int (EMACS_INT num);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
171 EMACS_INT
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
172 sign_extend_lisp_int (EMACS_INT num)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
173 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
174 if (num & (1L << (VALBITS - 1)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
175 return num | ((-1L) << VALBITS);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
176 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
177 return num & ((1L << VALBITS) - 1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
178 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
179
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
180
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
181 /* Data type predicates */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
182
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
183 DEFUN ("eq", Feq, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
184 Return t if the two args are the same Lisp object.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
185 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
186 (object1, object2))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
187 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
188 return EQ_WITH_EBOLA_NOTICE (object1, object2) ? Qt : Qnil;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
189 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
190
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
191 DEFUN ("old-eq", Fold_eq, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
192 Return t if the two args are (in most cases) the same Lisp object.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
193
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
194 Special kludge: A character is considered `old-eq' to its equivalent integer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
195 even though they are not the same object and are in fact of different
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
196 types. This is ABSOLUTELY AND UTTERLY HORRENDOUS but is necessary to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
197 preserve byte-code compatibility with v19. This kludge is known as the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
198 \"char-int confoundance disease\" and appears in a number of other
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
199 functions with `old-foo' equivalents.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
200
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
201 Do not use this function!
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
202 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
203 (object1, object2))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
204 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
205 /* #### blasphemy */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
206 return HACKEQ_UNSAFE (object1, object2) ? Qt : Qnil;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
207 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
208
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
209 DEFUN ("null", Fnull, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
210 Return t if OBJECT is nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
211 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
212 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
213 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
214 return NILP (object) ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
215 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
216
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
217 DEFUN ("consp", Fconsp, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
218 Return t if OBJECT is a cons cell. `nil' is not a cons cell.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
219 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
220 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
221 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
222 return CONSP (object) ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
223 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
224
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
225 DEFUN ("atom", Fatom, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
226 Return t if OBJECT is not a cons cell. `nil' is not a cons cell.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
227 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
228 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
229 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
230 return CONSP (object) ? Qnil : Qt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
231 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
232
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
233 DEFUN ("listp", Flistp, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
234 Return t if OBJECT is a list. `nil' is a list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
235 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
236 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
237 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
238 return LISTP (object) ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
239 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
240
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
241 DEFUN ("nlistp", Fnlistp, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
242 Return t if OBJECT is not a list. `nil' is a list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
243 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
244 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
245 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
246 return LISTP (object) ? Qnil : Qt;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
247 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
248
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
249 DEFUN ("true-list-p", Ftrue_list_p, 1, 1, 0, /*
1551
ddcdeb1a25c4 [xemacs-hg @ 2003-06-30 09:45:42 by stephent]
stephent
parents: 1330
diff changeset
250 Return t if OBJECT is an acyclic, nil-terminated (ie, not dotted), list.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
251 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
252 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
253 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
254 return TRUE_LIST_P (object) ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
255 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
256
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
257 DEFUN ("symbolp", Fsymbolp, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
258 Return t if OBJECT is a symbol.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
259 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
260 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
261 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
262 return SYMBOLP (object) ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
263 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
264
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
265 DEFUN ("keywordp", Fkeywordp, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
266 Return t if OBJECT is a keyword.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
267 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
268 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
269 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
270 return KEYWORDP (object) ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
271 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
272
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
273 DEFUN ("vectorp", Fvectorp, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
274 Return t if OBJECT is a vector.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
275 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
276 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
277 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
278 return VECTORP (object) ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
279 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
280
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
281 DEFUN ("bit-vector-p", Fbit_vector_p, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
282 Return t if OBJECT is a bit vector.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
283 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
284 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
285 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
286 return BIT_VECTORP (object) ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
287 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
288
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
289 DEFUN ("stringp", Fstringp, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
290 Return t if OBJECT is a string.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
291 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
292 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
293 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
294 return STRINGP (object) ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
295 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
296
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
297 DEFUN ("arrayp", Farrayp, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
298 Return t if OBJECT is an array (string, vector, or bit vector).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
299 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
300 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
301 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
302 return (VECTORP (object) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
303 STRINGP (object) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
304 BIT_VECTORP (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
305 ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
306 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
307
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
308 DEFUN ("sequencep", Fsequencep, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
309 Return t if OBJECT is a sequence (list or array).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
310 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
311 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
312 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
313 return (LISTP (object) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
314 VECTORP (object) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
315 STRINGP (object) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
316 BIT_VECTORP (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
317 ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
318 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
319
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
320 DEFUN ("markerp", Fmarkerp, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
321 Return t if OBJECT is a marker (editor pointer).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
322 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
323 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
324 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
325 return MARKERP (object) ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
326 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
327
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
328 DEFUN ("subrp", Fsubrp, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
329 Return t if OBJECT is a built-in function.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
330 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
331 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
332 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
333 return SUBRP (object) ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
334 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
335
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
336 DEFUN ("subr-min-args", Fsubr_min_args, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
337 Return minimum number of args built-in function SUBR may be called with.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
338 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
339 (subr))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
340 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
341 CHECK_SUBR (subr);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
342 return make_int (XSUBR (subr)->min_args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
343 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
344
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
345 DEFUN ("subr-max-args", Fsubr_max_args, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
346 Return maximum number of args built-in function SUBR may be called with,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
347 or nil if it takes an arbitrary number of arguments or is a special form.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
348 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
349 (subr))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
350 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
351 int nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
352 CHECK_SUBR (subr);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
353 nargs = XSUBR (subr)->max_args;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
354 if (nargs == MANY || nargs == UNEVALLED)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
355 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
356 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
357 return make_int (nargs);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
358 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
359
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
360 DEFUN ("subr-interactive", Fsubr_interactive, 1, 1, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
361 Return the interactive spec of the subr object SUBR, or nil.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
362 If non-nil, the return value will be a list whose first element is
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
363 `interactive' and whose second element is the interactive spec.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
364 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
365 (subr))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
366 {
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
367 const CIbyte *prompt;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
368 CHECK_SUBR (subr);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
369 prompt = XSUBR (subr)->prompt;
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 665
diff changeset
370 return prompt ? list2 (Qinteractive, build_msg_string (prompt)) : Qnil;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
371 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
372
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
373
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
374 DEFUN ("characterp", Fcharacterp, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
375 Return t if OBJECT is a character.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
376 Unlike in XEmacs v19 and FSF Emacs, a character is its own primitive type.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
377 Any character can be converted into an equivalent integer using
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
378 `char-int'. To convert the other way, use `int-char'; however,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
379 only some integers can be converted into characters. Such an integer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
380 is called a `char-int'; see `char-int-p'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
381
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
382 Some functions that work on integers (e.g. the comparison functions
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
383 <, <=, =, /=, etc. and the arithmetic functions +, -, *, etc.)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
384 accept characters and implicitly convert them into integers. In
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
385 general, functions that work on characters also accept char-ints and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
386 implicitly convert them into characters. WARNING: Neither of these
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
387 behaviors is very desirable, and they are maintained for backward
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
388 compatibility with old E-Lisp programs that confounded characters and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
389 integers willy-nilly. These behaviors may change in the future; therefore,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
390 do not rely on them. Instead, use the character-specific functions such
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
391 as `char='.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
392 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
393 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
394 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
395 return CHARP (object) ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
396 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
397
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
398 DEFUN ("char-to-int", Fchar_to_int, 1, 1, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
399 Convert CHARACTER into an equivalent integer.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
400 The resulting integer will always be non-negative. The integers in
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
401 the range 0 - 255 map to characters as follows:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
402
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
403 0 - 31 Control set 0
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
404 32 - 127 ASCII
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
405 128 - 159 Control set 1
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
406 160 - 255 Right half of ISO-8859-1
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
407
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
408 If support for Mule does not exist, these are the only valid character
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
409 values. When Mule support exists, the values assigned to other characters
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
410 may vary depending on the particular version of XEmacs, the order in which
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
411 character sets were loaded, etc., and you should not depend on them.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
412 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
413 (character))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
414 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
415 CHECK_CHAR (character);
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
416 return make_int (XCHAR (character));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
417 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
418
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
419 DEFUN ("int-to-char", Fint_to_char, 1, 1, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
420 Convert integer INTEGER into the equivalent character.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
421 Not all integers correspond to valid characters; use `char-int-p' to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
422 determine whether this is the case. If the integer cannot be converted,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
423 nil is returned.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
424 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
425 (integer))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
426 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
427 CHECK_INT (integer);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
428 if (CHAR_INTP (integer))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
429 return make_char (XINT (integer));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
430 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
431 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
432 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
433
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
434 DEFUN ("char-int-p", Fchar_int_p, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
435 Return t if OBJECT is an integer that can be converted into a character.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
436 See `char-int'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
437 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
438 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
439 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
440 return CHAR_INTP (object) ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
441 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
442
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
443 DEFUN ("char-or-char-int-p", Fchar_or_char_int_p, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
444 Return t if OBJECT is a character or an integer that can be converted into one.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
445 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
446 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
447 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
448 return CHAR_OR_CHAR_INTP (object) ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
449 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
450
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
451 DEFUN ("char-or-string-p", Fchar_or_string_p, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
452 Return t if OBJECT is a character (or a char-int) or a string.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
453 It is semi-hateful that we allow a char-int here, as it goes against
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
454 the name of this function, but it makes the most sense considering the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
455 other steps we take to maintain compatibility with the old character/integer
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
456 confoundedness in older versions of E-Lisp.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
457 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
458 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
459 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
460 return CHAR_OR_CHAR_INTP (object) || STRINGP (object) ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
461 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
462
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
463 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
464 /* In this case, integerp is defined in number.c. */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
465 DEFUN ("fixnump", Ffixnump, 1, 1, 0, /*
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
466 Return t if OBJECT is a fixnum.
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
467 */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
468 (object))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
469 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
470 return INTP (object) ? Qt : Qnil;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
471 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
472 #else
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
473 DEFUN ("integerp", Fintegerp, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
474 Return t if OBJECT is an integer.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
475 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
476 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
477 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
478 return INTP (object) ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
479 }
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
480 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
481
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
482 DEFUN ("integer-or-marker-p", Finteger_or_marker_p, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
483 Return t if OBJECT is an integer or a marker (editor pointer).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
484 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
485 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
486 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
487 return INTP (object) || MARKERP (object) ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
488 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
489
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
490 DEFUN ("integer-or-char-p", Finteger_or_char_p, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
491 Return t if OBJECT is an integer or a character.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
492 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
493 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
494 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
495 return INTP (object) || CHARP (object) ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
496 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
497
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
498 DEFUN ("integer-char-or-marker-p", Finteger_char_or_marker_p, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
499 Return t if OBJECT is an integer, character or a marker (editor pointer).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
500 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
501 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
502 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
503 return INTP (object) || CHARP (object) || MARKERP (object) ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
504 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
505
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
506 DEFUN ("natnump", Fnatnump, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
507 Return t if OBJECT is a nonnegative integer.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
508 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
509 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
510 {
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
511 return NATNUMP (object)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
512 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
513 || (BIGNUMP (object) && bignum_sign (XBIGNUM_DATA (object)) >= 0)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
514 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
515 ? Qt : Qnil;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
516 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
517
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
518 DEFUN ("nonnegativep", Fnonnegativep, 1, 1, 0, /*
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
519 Return t if OBJECT is a nonnegative number.
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
520 */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
521 (object))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
522 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
523 return NATNUMP (object)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
524 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
525 || (BIGNUMP (object) && bignum_sign (XBIGNUM_DATA (object)) >= 0)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
526 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
527 #ifdef HAVE_RATIO
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
528 || (RATIOP (object) && ratio_sign (XRATIO_DATA (object)) >= 0)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
529 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
530 #ifdef HAVE_BIGFLOAT
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
531 || (BIGFLOATP (object) && bigfloat_sign (XBIGFLOAT_DATA (object)) >= 0)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
532 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
533 ? Qt : Qnil;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
534 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
535
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
536 DEFUN ("bitp", Fbitp, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
537 Return t if OBJECT is a bit (0 or 1).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
538 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
539 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
540 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
541 return BITP (object) ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
542 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
543
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
544 DEFUN ("numberp", Fnumberp, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
545 Return t if OBJECT is a number (floating point or integer).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
546 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
547 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
548 {
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
549 #ifdef WITH_NUMBER_TYPES
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
550 return NUMBERP (object) ? Qt : Qnil;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
551 #else
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
552 return INT_OR_FLOATP (object) ? Qt : Qnil;
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
553 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
554 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
555
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
556 DEFUN ("number-or-marker-p", Fnumber_or_marker_p, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
557 Return t if OBJECT is a number or a marker.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
558 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
559 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
560 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
561 return INT_OR_FLOATP (object) || MARKERP (object) ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
562 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
563
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
564 DEFUN ("number-char-or-marker-p", Fnumber_char_or_marker_p, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
565 Return t if OBJECT is a number, character or a marker.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
566 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
567 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
568 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
569 return (INT_OR_FLOATP (object) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
570 CHARP (object) ||
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
571 MARKERP (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
572 ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
573 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
574
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
575 DEFUN ("floatp", Ffloatp, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
576 Return t if OBJECT is a floating point number.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
577 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
578 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
579 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
580 return FLOATP (object) ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
581 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
582
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
583 DEFUN ("type-of", Ftype_of, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
584 Return a symbol representing the type of OBJECT.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
585 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
586 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
587 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
588 switch (XTYPE (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
589 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
590 case Lisp_Type_Record:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
591 return intern (XRECORD_LHEADER_IMPLEMENTATION (object)->name);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
592
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
593 case Lisp_Type_Char: return Qcharacter;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
594
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
595 default: return Qinteger;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
596 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
597 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
598
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
599
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
600 /* Extract and set components of lists */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
601
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
602 DEFUN ("car", Fcar, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
603 Return the car of LIST. If arg is nil, return nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
604 Error if arg is not nil and not a cons cell. See also `car-safe'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
605 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
606 (list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
607 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
608 while (1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
609 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
610 if (CONSP (list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
611 return XCAR (list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
612 else if (NILP (list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
613 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
614 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
615 list = wrong_type_argument (Qlistp, list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
616 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
617 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
618
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
619 DEFUN ("car-safe", Fcar_safe, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
620 Return the car of OBJECT if it is a cons cell, or else nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
621 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
622 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
623 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
624 return CONSP (object) ? XCAR (object) : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
625 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
626
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
627 DEFUN ("cdr", Fcdr, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
628 Return the cdr of LIST. If arg is nil, return nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
629 Error if arg is not nil and not a cons cell. See also `cdr-safe'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
630 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
631 (list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
632 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
633 while (1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
634 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
635 if (CONSP (list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
636 return XCDR (list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
637 else if (NILP (list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
638 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
639 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
640 list = wrong_type_argument (Qlistp, list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
641 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
642 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
643
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
644 DEFUN ("cdr-safe", Fcdr_safe, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
645 Return the cdr of OBJECT if it is a cons cell, else nil.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
646 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
647 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
648 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
649 return CONSP (object) ? XCDR (object) : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
650 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
651
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
652 DEFUN ("setcar", Fsetcar, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
653 Set the car of CONS-CELL to be NEWCAR. Return NEWCAR.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
654 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
655 (cons_cell, newcar))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
656 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
657 if (!CONSP (cons_cell))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
658 cons_cell = wrong_type_argument (Qconsp, cons_cell);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
659
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
660 XCAR (cons_cell) = newcar;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
661 return newcar;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
662 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
663
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
664 DEFUN ("setcdr", Fsetcdr, 2, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
665 Set the cdr of CONS-CELL to be NEWCDR. Return NEWCDR.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
666 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
667 (cons_cell, newcdr))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
668 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
669 if (!CONSP (cons_cell))
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
670 cons_cell = wrong_type_argument (Qconsp, cons_cell);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
671
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
672 XCDR (cons_cell) = newcdr;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
673 return newcdr;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
674 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
675
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
676 /* Find the function at the end of a chain of symbol function indirections.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
677
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
678 If OBJECT is a symbol, find the end of its function chain and
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
679 return the value found there. If OBJECT is not a symbol, just
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
680 return it. If there is a cycle in the function chain, signal a
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
681 cyclic-function-indirection error.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
682
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
683 This is like Findirect_function when VOID_FUNCTION_ERRORP is true.
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
684 When VOID_FUNCTION_ERRORP is false, no error is signaled if the end
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
685 of the chain ends up being Qunbound. */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
686 Lisp_Object
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
687 indirect_function (Lisp_Object object, int void_function_errorp)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
688 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
689 #define FUNCTION_INDIRECTION_SUSPICION_LENGTH 16
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
690 Lisp_Object tortoise, hare;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
691 int count;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
692
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
693 for (hare = tortoise = object, count = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
694 SYMBOLP (hare);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
695 hare = XSYMBOL (hare)->function, count++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
696 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
697 if (count < FUNCTION_INDIRECTION_SUSPICION_LENGTH) continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
698
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
699 if (count & 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
700 tortoise = XSYMBOL (tortoise)->function;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
701 if (EQ (hare, tortoise))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
702 return Fsignal (Qcyclic_function_indirection, list1 (object));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
703 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
704
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
705 if (void_function_errorp && UNBOUNDP (hare))
436
080151679be2 Import from CVS: tag r21-2-26
cvs
parents: 428
diff changeset
706 return signal_void_function_error (object);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
707
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
708 return hare;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
709 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
710
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
711 DEFUN ("indirect-function", Findirect_function, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
712 Return the function at the end of OBJECT's function chain.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
713 If OBJECT is a symbol, follow all function indirections and return
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
714 the final function binding.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
715 If OBJECT is not a symbol, just return it.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
716 Signal a void-function error if the final symbol is unbound.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
717 Signal a cyclic-function-indirection error if there is a loop in the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
718 function chain of symbols.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
719 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
720 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
721 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
722 return indirect_function (object, 1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
723 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
724
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
725 /* Extract and set vector and string elements */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
726
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
727 DEFUN ("aref", Faref, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
728 Return the element of ARRAY at index INDEX.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
729 ARRAY may be a vector, bit vector, or string. INDEX starts at 0.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
730 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
731 (array, index_))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
732 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
733 EMACS_INT idx;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
734
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
735 retry:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
736
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
737 if (INTP (index_)) idx = XINT (index_);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
738 else if (CHARP (index_)) idx = XCHAR (index_); /* yuck! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
739 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
740 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
741 index_ = wrong_type_argument (Qinteger_or_char_p, index_);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
742 goto retry;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
743 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
744
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
745 if (idx < 0) goto range_error;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
746
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
747 if (VECTORP (array))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
748 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
749 if (idx >= XVECTOR_LENGTH (array)) goto range_error;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
750 return XVECTOR_DATA (array)[idx];
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
751 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
752 else if (BIT_VECTORP (array))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
753 {
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 613
diff changeset
754 if (idx >= (EMACS_INT) bit_vector_length (XBIT_VECTOR (array)))
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 613
diff changeset
755 goto range_error;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
756 return make_int (bit_vector_bit (XBIT_VECTOR (array), idx));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
757 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
758 else if (STRINGP (array))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
759 {
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 801
diff changeset
760 if (idx >= string_char_length (array)) goto range_error;
867
804517e16990 [xemacs-hg @ 2002-06-05 09:54:39 by ben]
ben
parents: 858
diff changeset
761 return make_char (string_ichar (array, idx));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
762 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
763 #ifdef LOSING_BYTECODE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
764 else if (COMPILED_FUNCTIONP (array))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
765 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
766 /* Weird, gross compatibility kludge */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
767 return Felt (array, index_);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
768 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
769 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
770 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
771 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
772 check_losing_bytecode ("aref", array);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
773 array = wrong_type_argument (Qarrayp, array);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
774 goto retry;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
775 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
776
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
777 range_error:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
778 args_out_of_range (array, index_);
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1104
diff changeset
779 RETURN_NOT_REACHED (Qnil);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
780 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
781
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
782 DEFUN ("aset", Faset, 3, 3, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
783 Store into the element of ARRAY at index INDEX the value NEWVAL.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
784 ARRAY may be a vector, bit vector, or string. INDEX starts at 0.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
785 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
786 (array, index_, newval))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
787 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
788 EMACS_INT idx;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
789
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
790 retry:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
791
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
792 if (INTP (index_)) idx = XINT (index_);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
793 else if (CHARP (index_)) idx = XCHAR (index_); /* yuck! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
794 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
795 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
796 index_ = wrong_type_argument (Qinteger_or_char_p, index_);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
797 goto retry;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
798 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
799
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
800 if (idx < 0) goto range_error;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
801
771
943eaba38521 [xemacs-hg @ 2002-03-13 08:51:24 by ben]
ben
parents: 665
diff changeset
802 CHECK_LISP_WRITEABLE (array);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
803 if (VECTORP (array))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
804 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
805 if (idx >= XVECTOR_LENGTH (array)) goto range_error;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
806 XVECTOR_DATA (array)[idx] = newval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
807 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
808 else if (BIT_VECTORP (array))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
809 {
647
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 613
diff changeset
810 if (idx >= (EMACS_INT) bit_vector_length (XBIT_VECTOR (array)))
b39c14581166 [xemacs-hg @ 2001-08-13 04:45:47 by ben]
ben
parents: 613
diff changeset
811 goto range_error;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
812 CHECK_BIT (newval);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
813 set_bit_vector_bit (XBIT_VECTOR (array), idx, !ZEROP (newval));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
814 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
815 else if (STRINGP (array))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
816 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
817 CHECK_CHAR_COERCE_INT (newval);
826
6728e641994e [xemacs-hg @ 2002-05-05 11:30:15 by ben]
ben
parents: 801
diff changeset
818 if (idx >= string_char_length (array)) goto range_error;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
819 set_string_char (array, idx, XCHAR (newval));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
820 bump_string_modiff (array);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
821 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
822 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
823 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
824 array = wrong_type_argument (Qarrayp, array);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
825 goto retry;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
826 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
827
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
828 return newval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
829
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
830 range_error:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
831 args_out_of_range (array, index_);
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1104
diff changeset
832 RETURN_NOT_REACHED (Qnil);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
833 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
834
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
835
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
836 /**********************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
837 /* Arithmetic functions */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
838 /**********************************************************************/
2001
cc5b615380f8 [xemacs-hg @ 2004-04-08 15:23:07 by james]
james
parents: 1995
diff changeset
839 #ifndef WITH_NUMBER_TYPES
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
840 typedef struct
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
841 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
842 int int_p;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
843 union
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
844 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
845 EMACS_INT ival;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
846 double dval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
847 } c;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
848 } int_or_double;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
849
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
850 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
851 number_char_or_marker_to_int_or_double (Lisp_Object obj, int_or_double *p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
852 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
853 retry:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
854 p->int_p = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
855 if (INTP (obj)) p->c.ival = XINT (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
856 else if (CHARP (obj)) p->c.ival = XCHAR (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
857 else if (MARKERP (obj)) p->c.ival = marker_position (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
858 else if (FLOATP (obj)) p->c.dval = XFLOAT_DATA (obj), p->int_p = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
859 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
860 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
861 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
862 goto retry;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
863 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
864 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
865
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
866 static double
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
867 number_char_or_marker_to_double (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
868 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
869 retry:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
870 if (INTP (obj)) return (double) XINT (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
871 else if (CHARP (obj)) return (double) XCHAR (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
872 else if (MARKERP (obj)) return (double) marker_position (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
873 else if (FLOATP (obj)) return XFLOAT_DATA (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
874 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
875 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
876 obj = wrong_type_argument (Qnumber_char_or_marker_p, obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
877 goto retry;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
878 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
879 }
2001
cc5b615380f8 [xemacs-hg @ 2004-04-08 15:23:07 by james]
james
parents: 1995
diff changeset
880 #endif /* WITH_NUMBER_TYPES */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
881
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
882 static EMACS_INT
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
883 integer_char_or_marker_to_int (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
884 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
885 retry:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
886 if (INTP (obj)) return XINT (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
887 else if (CHARP (obj)) return XCHAR (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
888 else if (MARKERP (obj)) return marker_position (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
889 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
890 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
891 obj = wrong_type_argument (Qinteger_char_or_marker_p, obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
892 goto retry;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
893 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
894 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
895
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
896 #ifdef WITH_NUMBER_TYPES
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
897
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
898 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
899 #define BIGNUM_CASE(op) \
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
900 case BIGNUM_T: \
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
901 if (!bignum_##op (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2))) \
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
902 return Qnil; \
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
903 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
904 #else
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
905 #define BIGNUM_CASE(op)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
906 #endif /* HAVE_BIGNUM */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
907
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
908 #ifdef HAVE_RATIO
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
909 #define RATIO_CASE(op) \
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
910 case RATIO_T: \
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
911 if (!ratio_##op (XRATIO_DATA (obj1), XRATIO_DATA (obj2))) \
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
912 return Qnil; \
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
913 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
914 #else
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
915 #define RATIO_CASE(op)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
916 #endif /* HAVE_RATIO */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
917
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
918 #ifdef HAVE_BIGFLOAT
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
919 #define BIGFLOAT_CASE(op) \
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
920 case BIGFLOAT_T: \
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
921 if (!bigfloat_##op (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2))) \
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
922 return Qnil; \
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
923 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
924 #else
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
925 #define BIGFLOAT_CASE(op)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
926 #endif /* HAVE_BIGFLOAT */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
927
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
928 #define ARITHCOMPARE_MANY(c_op,op) \
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
929 { \
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
930 REGISTER int i; \
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
931 Lisp_Object obj1, obj2; \
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
932 \
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
933 for (i = 1; i < nargs; i++) \
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
934 { \
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
935 obj1 = args[i - 1]; \
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
936 obj2 = args[i]; \
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
937 switch (promote_args (&obj1, &obj2)) \
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
938 { \
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
939 case FIXNUM_T: \
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
940 if (!(XREALINT (obj1) c_op XREALINT (obj2))) \
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
941 return Qnil; \
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
942 break; \
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
943 BIGNUM_CASE (op) \
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
944 RATIO_CASE (op) \
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
945 case FLOAT_T: \
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
946 if (!(XFLOAT_DATA (obj1) c_op XFLOAT_DATA (obj2))) \
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
947 return Qnil; \
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
948 break; \
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
949 BIGFLOAT_CASE (op) \
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
950 } \
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
951 } \
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
952 return Qt; \
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
953 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
954 #else /* !WITH_NUMBER_TYPES */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
955 #define ARITHCOMPARE_MANY(c_op,op) \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
956 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
957 int_or_double iod1, iod2, *p = &iod1, *q = &iod2; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
958 Lisp_Object *args_end = args + nargs; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
959 \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
960 number_char_or_marker_to_int_or_double (*args++, p); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
961 \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
962 while (args < args_end) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
963 { \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
964 number_char_or_marker_to_int_or_double (*args++, q); \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
965 \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
966 if (!((p->int_p && q->int_p) ? \
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
967 (p->c.ival c_op q->c.ival) : \
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
968 ((p->int_p ? (double) p->c.ival : p->c.dval) c_op \
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
969 (q->int_p ? (double) q->c.ival : q->c.dval)))) \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
970 return Qnil; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
971 \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
972 { /* swap */ int_or_double *r = p; p = q; q = r; } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
973 } \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
974 return Qt; \
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
975 }
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
976 #endif /* WITH_NUMBER_TYPES */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
977
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
978 DEFUN ("=", Feqlsign, 1, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
979 Return t if all the arguments are numerically equal.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
980 The arguments may be numbers, characters or markers.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
981 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
982 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
983 {
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
984 ARITHCOMPARE_MANY (==, eql)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
985 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
986
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
987 DEFUN ("<", Flss, 1, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
988 Return t if the sequence of arguments is monotonically increasing.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
989 The arguments may be numbers, characters or markers.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
990 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
991 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
992 {
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
993 ARITHCOMPARE_MANY (<, lt)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
994 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
995
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
996 DEFUN (">", Fgtr, 1, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
997 Return t if the sequence of arguments is monotonically decreasing.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
998 The arguments may be numbers, characters or markers.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
999 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1000 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1001 {
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1002 ARITHCOMPARE_MANY (>, gt)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1003 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1004
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1005 DEFUN ("<=", Fleq, 1, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1006 Return t if the sequence of arguments is monotonically nondecreasing.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1007 The arguments may be numbers, characters or markers.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1008 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1009 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1010 {
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1011 ARITHCOMPARE_MANY (<=, le)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1012 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1013
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1014 DEFUN (">=", Fgeq, 1, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1015 Return t if the sequence of arguments is monotonically nonincreasing.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1016 The arguments may be numbers, characters or markers.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1017 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1018 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1019 {
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1020 ARITHCOMPARE_MANY (>=, ge)
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1021 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1022
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1023 /* Unlike all the other comparisons, this is an O(N*N) algorithm. But who
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1024 cares? Inspection of all elisp code distributed by xemacs.org shows that
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1025 it is almost always called with 2 arguments, rarely with 3, and never with
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1026 more than 3. The constant factors of algorithms with better asymptotic
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1027 complexity are higher, which means that those algorithms will run SLOWER
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1028 than this one in the common case. Optimize the common case! */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1029 DEFUN ("/=", Fneq, 1, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1030 Return t if no two arguments are numerically equal.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1031 The arguments may be numbers, characters or markers.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1032 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1033 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1034 {
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1035 #ifdef WITH_NUMBER_TYPES
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1036 REGISTER int i, j;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1037 Lisp_Object obj1, obj2;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1038
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1039 for (i = 0; i < nargs - 1; i++)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1040 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1041 obj1 = args[i];
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1042 for (j = i + 1; j < nargs; j++)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1043 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1044 obj2 = args[j];
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1045 switch (promote_args (&obj1, &obj2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1046 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1047 case FIXNUM_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1048 if (XREALINT (obj1) == XREALINT (obj2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1049 return Qnil;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1050 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1051 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1052 case BIGNUM_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1053 if (bignum_eql (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2)))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1054 return Qnil;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1055 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1056 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1057 #ifdef HAVE_RATIO
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1058 case RATIO_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1059 if (ratio_eql (XRATIO_DATA (obj1), XRATIO_DATA (obj2)))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1060 return Qnil;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1061 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1062 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1063 case FLOAT_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1064 if (XFLOAT_DATA (obj1) == XFLOAT_DATA (obj2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1065 return Qnil;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1066 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1067 #ifdef HAVE_BIGFLOAT
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1068 case BIGFLOAT_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1069 if (bigfloat_eql (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2)))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1070 return Qnil;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1071 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1072 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1073 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1074 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1075 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1076 return Qt;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1077 #else /* !WITH_NUMBER_TYPES */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1078 Lisp_Object *args_end = args + nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1079 Lisp_Object *p, *q;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1080
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1081 /* Unlike all the other comparisons, this is an N*N algorithm.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1082 We could use a hash table for nargs > 50 to make this linear. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1083 for (p = args; p < args_end; p++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1084 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1085 int_or_double iod1, iod2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1086 number_char_or_marker_to_int_or_double (*p, &iod1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1087
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1088 for (q = p + 1; q < args_end; q++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1089 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1090 number_char_or_marker_to_int_or_double (*q, &iod2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1091
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1092 if (!((iod1.int_p && iod2.int_p) ?
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1093 (iod1.c.ival != iod2.c.ival) :
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1094 ((iod1.int_p ? (double) iod1.c.ival : iod1.c.dval) !=
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1095 (iod2.int_p ? (double) iod2.c.ival : iod2.c.dval))))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1096 return Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1097 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1098 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1099 return Qt;
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1100 #endif /* WITH_NUMBER_TYPES */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1101 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1102
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1103 DEFUN ("zerop", Fzerop, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1104 Return t if NUMBER is zero.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1105 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1106 (number))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1107 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1108 retry:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1109 if (INTP (number))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1110 return EQ (number, Qzero) ? Qt : Qnil;
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1111 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1112 else if (BIGNUMP (number))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1113 return bignum_sign (XBIGNUM_DATA (number)) == 0 ? Qt : Qnil;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1114 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1115 #ifdef HAVE_RATIO
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1116 else if (RATIOP (number))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1117 return ratio_sign (XRATIO_DATA (number)) == 0 ? Qt : Qnil;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1118 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1119 else if (FLOATP (number))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1120 return XFLOAT_DATA (number) == 0.0 ? Qt : Qnil;
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1121 #ifdef HAVE_BIGFLOAT
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1122 else if (BIGFLOATP (number))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1123 return bigfloat_sign (XBIGFLOAT_DATA (number)) == 0 ? Qt : Qnil;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1124 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1125 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1126 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1127 number = wrong_type_argument (Qnumberp, number);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1128 goto retry;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1129 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1130 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1131
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1132 /* Convert between a 32-bit value and a cons of two 16-bit values.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1133 This is used to pass 32-bit integers to and from the user.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1134 Use time_to_lisp() and lisp_to_time() for time values.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1135
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1136 If you're thinking of using this to store a pointer into a Lisp Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1137 for internal purposes (such as when calling record_unwind_protect()),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1138 try using make_opaque_ptr()/get_opaque_ptr() instead. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1139 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1140 word_to_lisp (unsigned int item)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1141 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1142 return Fcons (make_int (item >> 16), make_int (item & 0xffff));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1143 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1144
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1145 unsigned int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1146 lisp_to_word (Lisp_Object item)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1147 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1148 if (INTP (item))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1149 return XINT (item);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1150 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1151 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1152 Lisp_Object top = Fcar (item);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1153 Lisp_Object bot = Fcdr (item);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1154 CHECK_INT (top);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1155 CHECK_INT (bot);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1156 return (XINT (top) << 16) | (XINT (bot) & 0xffff);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1157 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1158 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1159
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1160
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1161 DEFUN ("number-to-string", Fnumber_to_string, 1, 1, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1162 Convert NUMBER to a string by printing it in decimal.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1163 Uses a minus sign if negative.
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1164 NUMBER may be an integer or a floating point number.
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1165 If supported, it may also be a ratio.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1166 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1167 (number))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1168 {
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1169 #ifdef WITH_NUMBER_TYPES
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1170 CHECK_NUMBER (number);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1171 #else
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1172 CHECK_INT_OR_FLOAT (number);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1173 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1174
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1175 if (FLOATP (number))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1176 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1177 char pigbuf[350]; /* see comments in float_to_string */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1178
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1179 float_to_string (pigbuf, XFLOAT_DATA (number));
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1180 return build_string (pigbuf);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1181 }
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1182 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1183 if (BIGNUMP (number))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1184 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1185 char *str = bignum_to_string (XBIGNUM_DATA (number), 10);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1186 Lisp_Object retval = build_string (str);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1187 xfree (str, char *);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1188 return retval;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1189 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1190 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1191 #ifdef HAVE_RATIO
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1192 if (RATIOP (number))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1193 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1194 char *str = ratio_to_string (XRATIO_DATA (number), 10);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1195 Lisp_Object retval = build_string (str);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1196 xfree (str, char *);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1197 return retval;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1198 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1199 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1200 #ifdef HAVE_BIGFLOAT
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1201 if (BIGFLOATP (number))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1202 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1203 char *str = bigfloat_to_string (XBIGFLOAT_DATA (number), 10);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1204 Lisp_Object retval = build_string (str);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1205 xfree (str, char *);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1206 return retval;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1207 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1208 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1209
603
1c880911c386 [xemacs-hg @ 2001-06-01 08:23:09 by martinb]
martinb
parents: 580
diff changeset
1210 {
1c880911c386 [xemacs-hg @ 2001-06-01 08:23:09 by martinb]
martinb
parents: 580
diff changeset
1211 char buffer[DECIMAL_PRINT_SIZE (long)];
1c880911c386 [xemacs-hg @ 2001-06-01 08:23:09 by martinb]
martinb
parents: 580
diff changeset
1212
1c880911c386 [xemacs-hg @ 2001-06-01 08:23:09 by martinb]
martinb
parents: 580
diff changeset
1213 long_to_string (buffer, XINT (number));
1c880911c386 [xemacs-hg @ 2001-06-01 08:23:09 by martinb]
martinb
parents: 580
diff changeset
1214 return build_string (buffer);
1c880911c386 [xemacs-hg @ 2001-06-01 08:23:09 by martinb]
martinb
parents: 580
diff changeset
1215 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1216 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1217
2001
cc5b615380f8 [xemacs-hg @ 2004-04-08 15:23:07 by james]
james
parents: 1995
diff changeset
1218 #ifndef HAVE_BIGNUM
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1219 static int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1220 digit_to_number (int character, int base)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1221 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1222 /* Assumes ASCII */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1223 int digit = ((character >= '0' && character <= '9') ? character - '0' :
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1224 (character >= 'a' && character <= 'z') ? character - 'a' + 10 :
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1225 (character >= 'A' && character <= 'Z') ? character - 'A' + 10 :
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1226 -1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1227
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1228 return digit >= base ? -1 : digit;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1229 }
2001
cc5b615380f8 [xemacs-hg @ 2004-04-08 15:23:07 by james]
james
parents: 1995
diff changeset
1230 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1231
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1232 DEFUN ("string-to-number", Fstring_to_number, 1, 2, 0, /*
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1233 Convert STRING to a number by parsing it as a number in base BASE.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1234 This parses both integers and floating point numbers.
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1235 If they are supported, it also reads ratios.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1236 It ignores leading spaces and tabs.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1237
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1238 If BASE is nil or omitted, base 10 is used.
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1239 BASE must be an integer between 2 and 16 (inclusive).
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1240 Floating point numbers always use base 10.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1241 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1242 (string, base))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1243 {
1995
4e6a63799f08 [xemacs-hg @ 2004-04-07 03:48:58 by james]
james
parents: 1994
diff changeset
1244 Ibyte *p;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1245 int b;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1246
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1247 CHECK_STRING (string);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1248
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1249 if (NILP (base))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1250 b = 10;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1251 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1252 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1253 CHECK_INT (base);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1254 b = XINT (base);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1255 check_int_range (b, 2, 16);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1256 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1257
1995
4e6a63799f08 [xemacs-hg @ 2004-04-07 03:48:58 by james]
james
parents: 1994
diff changeset
1258 p = XSTRING_DATA (string);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1259
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1260 /* Skip any whitespace at the front of the number. Some versions of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1261 atoi do this anyway, so we might as well make Emacs lisp consistent. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1262 while (*p == ' ' || *p == '\t')
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1263 p++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1264
1995
4e6a63799f08 [xemacs-hg @ 2004-04-07 03:48:58 by james]
james
parents: 1994
diff changeset
1265 if (isfloat_string ((const char *) p) && b == 10)
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1266 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1267 #ifdef HAVE_BIGFLOAT
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1268 if (ZEROP (Vdefault_float_precision))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1269 #endif
1995
4e6a63799f08 [xemacs-hg @ 2004-04-07 03:48:58 by james]
james
parents: 1994
diff changeset
1270 return make_float (atof ((const char *) p));
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1271 #ifdef HAVE_BIGFLOAT
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1272 else
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1273 {
2010
a9cdbfb4716e [xemacs-hg @ 2004-04-13 15:38:30 by james]
james
parents: 2001
diff changeset
1274 /* GMP bigfloat_set_string returns random values with initial + */
a9cdbfb4716e [xemacs-hg @ 2004-04-13 15:38:30 by james]
james
parents: 2001
diff changeset
1275 if (*p == '+')
a9cdbfb4716e [xemacs-hg @ 2004-04-13 15:38:30 by james]
james
parents: 2001
diff changeset
1276 p++;
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1277 bigfloat_set_prec (scratch_bigfloat, bigfloat_get_default_prec ());
1995
4e6a63799f08 [xemacs-hg @ 2004-04-07 03:48:58 by james]
james
parents: 1994
diff changeset
1278 bigfloat_set_string (scratch_bigfloat, (const char *) p, b);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1279 return make_bigfloat_bf (scratch_bigfloat);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1280 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1281 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1282 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1283
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1284 #ifdef HAVE_RATIO
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1285 if (qxestrchr (p, '/') != NULL)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1286 {
2010
a9cdbfb4716e [xemacs-hg @ 2004-04-13 15:38:30 by james]
james
parents: 2001
diff changeset
1287 /* GMP ratio_set_string returns random values with initial + sign */
a9cdbfb4716e [xemacs-hg @ 2004-04-13 15:38:30 by james]
james
parents: 2001
diff changeset
1288 if (*p == '+')
a9cdbfb4716e [xemacs-hg @ 2004-04-13 15:38:30 by james]
james
parents: 2001
diff changeset
1289 p++;
1995
4e6a63799f08 [xemacs-hg @ 2004-04-07 03:48:58 by james]
james
parents: 1994
diff changeset
1290 ratio_set_string (scratch_ratio, (const char *) p, b);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1291 return make_ratio_rt (scratch_ratio);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1292 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1293 #endif /* HAVE_RATIO */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1294
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1295 #ifdef HAVE_BIGNUM
2010
a9cdbfb4716e [xemacs-hg @ 2004-04-13 15:38:30 by james]
james
parents: 2001
diff changeset
1296 /* GMP bignum_set_string returns random values when the string starts with a
a9cdbfb4716e [xemacs-hg @ 2004-04-13 15:38:30 by james]
james
parents: 2001
diff changeset
1297 plus sign */
a9cdbfb4716e [xemacs-hg @ 2004-04-13 15:38:30 by james]
james
parents: 2001
diff changeset
1298 if (*p == '+')
a9cdbfb4716e [xemacs-hg @ 2004-04-13 15:38:30 by james]
james
parents: 2001
diff changeset
1299 p++;
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1300 /* GMP bignum_set_string returns random values when fed an empty string */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1301 if (*p == '\0')
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1302 return make_int (0);
1995
4e6a63799f08 [xemacs-hg @ 2004-04-07 03:48:58 by james]
james
parents: 1994
diff changeset
1303 bignum_set_string (scratch_bignum, (const char *) p, b);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1304 return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1305 #else
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1306 if (b == 10)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1307 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1308 /* Use the system-provided functions for base 10. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1309 #if SIZEOF_EMACS_INT == SIZEOF_INT
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1310 return make_int (atoi (p));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1311 #elif SIZEOF_EMACS_INT == SIZEOF_LONG
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1312 return make_int (atol (p));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1313 #elif SIZEOF_EMACS_INT == SIZEOF_LONG_LONG
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1314 return make_int (atoll (p));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1315 #endif
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1316 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1317 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1318 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1319 int negative = 1;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1320 EMACS_INT v = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1321
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1322 if (*p == '-')
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1323 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1324 negative = -1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1325 p++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1326 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1327 else if (*p == '+')
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1328 p++;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1329 while (1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1330 {
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
1331 int digit = digit_to_number (*p++, b);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1332 if (digit < 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1333 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1334 v = v * b + digit;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1335 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1336 return make_int (negative * v);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1337 }
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1338 #endif /* HAVE_BIGNUM */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1339 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1340
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1341
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1342 DEFUN ("+", Fplus, 0, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1343 Return sum of any number of arguments.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1344 The arguments should all be numbers, characters or markers.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1345 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1346 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1347 {
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1348 #ifdef WITH_NUMBER_TYPES
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1349 REGISTER int i;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1350 Lisp_Object accum = make_int (0), addend;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1351
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1352 for (i = 0; i < nargs; i++)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1353 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1354 addend = args[i];
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1355 switch (promote_args (&accum, &addend))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1356 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1357 case FIXNUM_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1358 accum = make_integer (XREALINT (accum) + XREALINT (addend));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1359 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1360 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1361 case BIGNUM_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1362 bignum_add (scratch_bignum, XBIGNUM_DATA (accum),
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1363 XBIGNUM_DATA (addend));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1364 accum = make_bignum_bg (scratch_bignum);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1365 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1366 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1367 #ifdef HAVE_RATIO
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1368 case RATIO_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1369 ratio_add (scratch_ratio, XRATIO_DATA (accum),
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1370 XRATIO_DATA (addend));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1371 accum = make_ratio_rt (scratch_ratio);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1372 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1373 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1374 case FLOAT_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1375 accum = make_float (XFLOAT_DATA (accum) + XFLOAT_DATA (addend));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1376 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1377 #ifdef HAVE_BIGFLOAT
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1378 case BIGFLOAT_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1379 bigfloat_set_prec (scratch_bigfloat,
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1380 max (XBIGFLOAT_GET_PREC (addend),
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1381 XBIGFLOAT_GET_PREC (accum)));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1382 bigfloat_add (scratch_bigfloat, XBIGFLOAT_DATA (accum),
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1383 XBIGFLOAT_DATA (addend));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1384 accum = make_bigfloat_bf (scratch_bigfloat);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1385 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1386 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1387 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1388 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1389 return Fcanonicalize_number (accum);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1390 #else /* !WITH_NUMBER_TYPES */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1391 EMACS_INT iaccum = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1392 Lisp_Object *args_end = args + nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1393
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1394 while (args < args_end)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1395 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1396 int_or_double iod;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1397 number_char_or_marker_to_int_or_double (*args++, &iod);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1398 if (iod.int_p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1399 iaccum += iod.c.ival;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1400 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1401 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1402 double daccum = (double) iaccum + iod.c.dval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1403 while (args < args_end)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1404 daccum += number_char_or_marker_to_double (*args++);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1405 return make_float (daccum);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1406 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1407 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1408
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1409 return make_int (iaccum);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1410 #endif /* WITH_NUMBER_TYPES */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1411 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1412
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1413 DEFUN ("-", Fminus, 1, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1414 Negate number or subtract numbers, characters or markers.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1415 With one arg, negates it. With more than one arg,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1416 subtracts all but the first from the first.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1417 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1418 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1419 {
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1420 #ifdef WITH_NUMBER_TYPES
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1421 REGISTER int i;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1422 Lisp_Object accum = args[0], subtrahend;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1423
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1424 if (nargs == 1)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1425 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1426 if (CHARP (accum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1427 accum = make_int (XCHAR (accum));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1428 else if (MARKERP (accum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1429 accum = make_int (marker_position (accum));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1430
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1431 /* Invert the sign of accum */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1432 CHECK_NUMBER (accum);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1433 switch (get_number_type (accum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1434 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1435 case FIXNUM_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1436 return make_integer (-XREALINT (accum));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1437 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1438 case BIGNUM_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1439 bignum_neg (scratch_bignum, XBIGNUM_DATA (accum));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1440 return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1441 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1442 #ifdef HAVE_RATIO
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1443 case RATIO_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1444 ratio_neg (scratch_ratio, XRATIO_DATA (accum));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1445 return make_ratio_rt (scratch_ratio);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1446 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1447 case FLOAT_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1448 return make_float (-XFLOAT_DATA (accum));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1449 #ifdef HAVE_BIGFLOAT
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1450 case BIGFLOAT_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1451 bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (accum));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1452 bigfloat_neg (scratch_bigfloat, XBIGFLOAT_DATA (accum));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1453 return make_bigfloat_bf (scratch_bigfloat);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1454 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1455 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1456 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1457 else
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1458 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1459 /* Subtrace the remaining arguments from accum */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1460 for (i = 1; i < nargs; i++)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1461 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1462 subtrahend = args[i];
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1463 switch (promote_args (&accum, &subtrahend))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1464 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1465 case FIXNUM_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1466 accum = make_integer (XREALINT (accum) - XREALINT (subtrahend));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1467 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1468 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1469 case BIGNUM_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1470 bignum_sub (scratch_bignum, XBIGNUM_DATA (accum),
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1471 XBIGNUM_DATA (subtrahend));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1472 accum = make_bignum_bg (scratch_bignum);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1473 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1474 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1475 #ifdef HAVE_RATIO
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1476 case RATIO_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1477 ratio_sub (scratch_ratio, XRATIO_DATA (accum),
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1478 XRATIO_DATA (subtrahend));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1479 accum = make_ratio_rt (scratch_ratio);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1480 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1481 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1482 case FLOAT_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1483 accum =
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1484 make_float (XFLOAT_DATA (accum) - XFLOAT_DATA (subtrahend));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1485 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1486 #ifdef HAVE_BIGFLOAT
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1487 case BIGFLOAT_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1488 bigfloat_set_prec (scratch_bigfloat,
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1489 max (XBIGFLOAT_GET_PREC (subtrahend),
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1490 XBIGFLOAT_GET_PREC (accum)));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1491 bigfloat_sub (scratch_bigfloat, XBIGFLOAT_DATA (accum),
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1492 XBIGFLOAT_DATA (subtrahend));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1493 accum = make_bigfloat_bf (scratch_bigfloat);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1494 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1495 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1496 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1497 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1498 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1499 return Fcanonicalize_number (accum);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1500 #else /* !WITH_NUMBER_TYPES */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1501 EMACS_INT iaccum;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1502 double daccum;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1503 Lisp_Object *args_end = args + nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1504 int_or_double iod;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1505
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1506 number_char_or_marker_to_int_or_double (*args++, &iod);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1507 if (iod.int_p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1508 iaccum = nargs > 1 ? iod.c.ival : - iod.c.ival;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1509 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1510 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1511 daccum = nargs > 1 ? iod.c.dval : - iod.c.dval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1512 goto do_float;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1513 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1514
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1515 while (args < args_end)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1516 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1517 number_char_or_marker_to_int_or_double (*args++, &iod);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1518 if (iod.int_p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1519 iaccum -= iod.c.ival;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1520 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1521 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1522 daccum = (double) iaccum - iod.c.dval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1523 goto do_float;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1524 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1525 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1526
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1527 return make_int (iaccum);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1528
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1529 do_float:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1530 for (; args < args_end; args++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1531 daccum -= number_char_or_marker_to_double (*args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1532 return make_float (daccum);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1533 #endif /* WITH_NUMBER_TYPES */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1534 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1535
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1536 DEFUN ("*", Ftimes, 0, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1537 Return product of any number of arguments.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1538 The arguments should all be numbers, characters or markers.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1539 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1540 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1541 {
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1542 #ifdef WITH_NUMBER_TYPES
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1543 REGISTER int i;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1544 /* Start with a bignum to avoid overflow */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1545 Lisp_Object accum = make_bignum (1L), multiplier;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1546
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1547 for (i = 0; i < nargs; i++)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1548 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1549 multiplier = args[i];
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1550 switch (promote_args (&accum, &multiplier))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1551 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1552 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1553 case BIGNUM_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1554 bignum_mul (scratch_bignum, XBIGNUM_DATA (accum),
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1555 XBIGNUM_DATA (multiplier));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1556 accum = make_bignum_bg (scratch_bignum);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1557 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1558 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1559 #ifdef HAVE_RATIO
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1560 case RATIO_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1561 ratio_mul (scratch_ratio, XRATIO_DATA (accum),
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1562 XRATIO_DATA (multiplier));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1563 accum = make_ratio_rt (scratch_ratio);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1564 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1565 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1566 case FLOAT_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1567 accum = make_float (XFLOAT_DATA (accum) * XFLOAT_DATA (multiplier));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1568 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1569 #ifdef HAVE_BIGFLOAT
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1570 case BIGFLOAT_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1571 bigfloat_set_prec (scratch_bigfloat,
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1572 max (XBIGFLOAT_GET_PREC (multiplier),
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1573 XBIGFLOAT_GET_PREC (accum)));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1574 bigfloat_mul (scratch_bigfloat, XBIGFLOAT_DATA (accum),
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1575 XBIGFLOAT_DATA (multiplier));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1576 accum = make_bigfloat_bf (scratch_bigfloat);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1577 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1578 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1579 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1580 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1581 return Fcanonicalize_number (accum);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1582 #else /* !WITH_NUMBER_TYPES */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1583 EMACS_INT iaccum = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1584 Lisp_Object *args_end = args + nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1585
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1586 while (args < args_end)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1587 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1588 int_or_double iod;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1589 number_char_or_marker_to_int_or_double (*args++, &iod);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1590 if (iod.int_p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1591 iaccum *= iod.c.ival;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1592 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1593 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1594 double daccum = (double) iaccum * iod.c.dval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1595 while (args < args_end)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1596 daccum *= number_char_or_marker_to_double (*args++);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1597 return make_float (daccum);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1598 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1599 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1600
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1601 return make_int (iaccum);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1602 #endif /* WITH_NUMBER_TYPES */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1603 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1604
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1605 #ifdef HAVE_RATIO
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1606 DEFUN ("div", Fdiv, 1, MANY, 0, /*
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1607 Same as `/', but dividing integers creates a ratio instead of truncating.
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1608 Note that this is a departure from Common Lisp, where / creates ratios when
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1609 dividing integers. Having a separate function lets us avoid breaking existing
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1610 Emacs Lisp code that expects / to do integer division.
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1611 */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1612 (int nargs, Lisp_Object *args))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1613 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1614 REGISTER int i;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1615 Lisp_Object accum, divisor;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1616
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1617 if (nargs == 1)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1618 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1619 i = 0;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1620 accum = make_int (1);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1621 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1622 else
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1623 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1624 i = 1;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1625 accum = args[0];
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1626 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1627 for (; i < nargs; i++)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1628 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1629 divisor = args[i];
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1630 switch (promote_args (&accum, &divisor))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1631 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1632 case FIXNUM_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1633 if (XREALINT (divisor) == 0) goto divide_by_zero;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1634 bignum_set_long (scratch_bignum, XREALINT (accum));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1635 bignum_set_long (scratch_bignum2, XREALINT (divisor));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1636 accum = make_ratio_bg (scratch_bignum, scratch_bignum2);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1637 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1638 case BIGNUM_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1639 if (bignum_sign (XBIGNUM_DATA (divisor)) == 0) goto divide_by_zero;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1640 accum = make_ratio_bg (XBIGNUM_DATA (accum), XBIGNUM_DATA (divisor));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1641 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1642 case RATIO_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1643 if (ratio_sign (XRATIO_DATA (divisor)) == 0) goto divide_by_zero;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1644 ratio_div (scratch_ratio, XRATIO_DATA (accum),
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1645 XRATIO_DATA (divisor));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1646 accum = make_ratio_rt (scratch_ratio);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1647 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1648 case FLOAT_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1649 if (XFLOAT_DATA (divisor) == 0.0) goto divide_by_zero;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1650 accum = make_float (XFLOAT_DATA (accum) / XFLOAT_DATA (divisor));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1651 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1652 #ifdef HAVE_BIGFLOAT
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1653 case BIGFLOAT_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1654 if (bigfloat_sign (XBIGFLOAT_DATA (divisor)) == 0)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1655 goto divide_by_zero;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1656 bigfloat_set_prec (scratch_bigfloat,
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1657 max (XBIGFLOAT_GET_PREC (divisor),
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1658 XBIGFLOAT_GET_PREC (accum)));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1659 bigfloat_div (scratch_bigfloat, XBIGFLOAT_DATA (accum),
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1660 XBIGFLOAT_DATA (divisor));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1661 accum = make_bigfloat_bf (scratch_bigfloat);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1662 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1663 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1664 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1665 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1666 return Fcanonicalize_number (accum);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1667
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1668 divide_by_zero:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1669 Fsignal (Qarith_error, Qnil);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1670 return Qnil; /* not (usually) reached */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1671 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1672 #endif /* HAVE_RATIO */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1673
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1674 DEFUN ("/", Fquo, 1, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1675 Return first argument divided by all the remaining arguments.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1676 The arguments must be numbers, characters or markers.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1677 With one argument, reciprocates the argument.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1678 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1679 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1680 {
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1681 #ifdef WITH_NUMBER_TYPES
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1682 REGISTER int i;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1683 Lisp_Object accum, divisor;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1684
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1685 if (nargs == 1)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1686 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1687 i = 0;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1688 accum = make_int (1);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1689 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1690 else
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1691 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1692 i = 1;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1693 accum = args[0];
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1694 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1695 for (; i < nargs; i++)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1696 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1697 divisor = args[i];
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1698 switch (promote_args (&accum, &divisor))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1699 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1700 case FIXNUM_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1701 if (XREALINT (divisor) == 0) goto divide_by_zero;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1702 accum = make_integer (XREALINT (accum) / XREALINT (divisor));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1703 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1704 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1705 case BIGNUM_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1706 if (bignum_sign (XBIGNUM_DATA (divisor)) == 0) goto divide_by_zero;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1707 bignum_div (scratch_bignum, XBIGNUM_DATA (accum),
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1708 XBIGNUM_DATA (divisor));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1709 accum = make_bignum_bg (scratch_bignum);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1710 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1711 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1712 #ifdef HAVE_RATIO
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1713 case RATIO_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1714 if (ratio_sign (XRATIO_DATA (divisor)) == 0) goto divide_by_zero;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1715 ratio_div (scratch_ratio, XRATIO_DATA (accum),
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1716 XRATIO_DATA (divisor));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1717 accum = make_ratio_rt (scratch_ratio);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1718 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1719 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1720 case FLOAT_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1721 if (XFLOAT_DATA (divisor) == 0.0) goto divide_by_zero;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1722 accum = make_float (XFLOAT_DATA (accum) / XFLOAT_DATA (divisor));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1723 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1724 #ifdef HAVE_BIGFLOAT
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1725 case BIGFLOAT_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1726 if (bigfloat_sign (XBIGFLOAT_DATA (divisor)) == 0)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1727 goto divide_by_zero;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1728 bigfloat_set_prec (scratch_bigfloat,
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1729 max (XBIGFLOAT_GET_PREC (divisor),
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1730 XBIGFLOAT_GET_PREC (accum)));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1731 bigfloat_div (scratch_bigfloat, XBIGFLOAT_DATA (accum),
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1732 XBIGFLOAT_DATA (divisor));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1733 accum = make_bigfloat_bf (scratch_bigfloat);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1734 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1735 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1736 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1737 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1738 return Fcanonicalize_number (accum);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1739 #else /* !WITH_NUMBER_TYPES */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1740 EMACS_INT iaccum;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1741 double daccum;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1742 Lisp_Object *args_end = args + nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1743 int_or_double iod;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1744
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1745 if (nargs == 1)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1746 iaccum = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1747 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1748 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1749 number_char_or_marker_to_int_or_double (*args++, &iod);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1750 if (iod.int_p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1751 iaccum = iod.c.ival;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1752 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1753 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1754 daccum = iod.c.dval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1755 goto divide_floats;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1756 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1757 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1758
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1759 while (args < args_end)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1760 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1761 number_char_or_marker_to_int_or_double (*args++, &iod);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1762 if (iod.int_p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1763 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1764 if (iod.c.ival == 0) goto divide_by_zero;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1765 iaccum /= iod.c.ival;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1766 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1767 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1768 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1769 if (iod.c.dval == 0) goto divide_by_zero;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1770 daccum = (double) iaccum / iod.c.dval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1771 goto divide_floats;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1772 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1773 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1774
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1775 return make_int (iaccum);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1776
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1777 divide_floats:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1778 for (; args < args_end; args++)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1779 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1780 double dval = number_char_or_marker_to_double (*args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1781 if (dval == 0) goto divide_by_zero;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1782 daccum /= dval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1783 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1784 return make_float (daccum);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1785 #endif /* WITH_NUMBER_TYPES */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1786
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1787 divide_by_zero:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1788 Fsignal (Qarith_error, Qnil);
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
1789 return Qnil; /* not (usually) reached */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1790 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1791
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1792 DEFUN ("max", Fmax, 1, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1793 Return largest of all the arguments.
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1794 All arguments must be real numbers, characters or markers.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1795 The value is always a number; markers and characters are converted
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1796 to numbers.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1797 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1798 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1799 {
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1800 #ifdef WITH_NUMBER_TYPES
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1801 REGISTER int i, maxindex = 0;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1802 Lisp_Object comp1, comp2;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1803
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1804 while (!(CHARP (args[0]) || MARKERP (args[0]) || REALP (args[0])))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1805 args[0] = wrong_type_argument (Qnumber_char_or_marker_p, args[0]);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1806 if (CHARP (args[0]))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1807 args[0] = make_int (XCHAR (args[0]));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1808 else if (MARKERP (args[0]))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1809 args[0] = make_int (marker_position (args[0]));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1810 for (i = 1; i < nargs; i++)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1811 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1812 comp1 = args[maxindex];
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1813 comp2 = args[i];
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1814 switch (promote_args (&comp1, &comp2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1815 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1816 case FIXNUM_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1817 if (XREALINT (comp1) < XREALINT (comp2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1818 maxindex = i;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1819 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1820 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1821 case BIGNUM_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1822 if (bignum_lt (XBIGNUM_DATA (comp1), XBIGNUM_DATA (comp2)))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1823 maxindex = i;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1824 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1825 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1826 #ifdef HAVE_RATIO
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1827 case RATIO_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1828 if (ratio_lt (XRATIO_DATA (comp1), XRATIO_DATA (comp2)))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1829 maxindex = i;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1830 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1831 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1832 case FLOAT_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1833 if (XFLOAT_DATA (comp1) < XFLOAT_DATA (comp2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1834 maxindex = i;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1835 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1836 #ifdef HAVE_BIGFLOAT
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1837 case BIGFLOAT_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1838 if (bigfloat_lt (XBIGFLOAT_DATA (comp1), XBIGFLOAT_DATA (comp2)))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1839 maxindex = i;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1840 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1841 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1842 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1843 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1844 return args[maxindex];
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1845 #else /* !WITH_NUMBER_TYPES */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1846 EMACS_INT imax;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1847 double dmax;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1848 Lisp_Object *args_end = args + nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1849 int_or_double iod;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1850
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1851 number_char_or_marker_to_int_or_double (*args++, &iod);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1852 if (iod.int_p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1853 imax = iod.c.ival;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1854 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1855 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1856 dmax = iod.c.dval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1857 goto max_floats;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1858 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1859
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1860 while (args < args_end)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1861 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1862 number_char_or_marker_to_int_or_double (*args++, &iod);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1863 if (iod.int_p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1864 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1865 if (imax < iod.c.ival) imax = iod.c.ival;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1866 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1867 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1868 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1869 dmax = (double) imax;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1870 if (dmax < iod.c.dval) dmax = iod.c.dval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1871 goto max_floats;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1872 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1873 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1874
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1875 return make_int (imax);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1876
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1877 max_floats:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1878 while (args < args_end)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1879 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1880 double dval = number_char_or_marker_to_double (*args++);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1881 if (dmax < dval) dmax = dval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1882 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1883 return make_float (dmax);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1884 #endif /* WITH_NUMBER_TYPES */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1885 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1886
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1887 DEFUN ("min", Fmin, 1, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1888 Return smallest of all the arguments.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1889 All arguments must be numbers, characters or markers.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1890 The value is always a number; markers and characters are converted
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1891 to numbers.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1892 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1893 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1894 {
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1895 #ifdef WITH_NUMBER_TYPES
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1896 REGISTER int i, minindex = 0;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1897 Lisp_Object comp1, comp2;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1898
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1899 while (!(CHARP (args[0]) || MARKERP (args[0]) || REALP (args[0])))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1900 args[0] = wrong_type_argument (Qnumber_char_or_marker_p, args[0]);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1901 if (CHARP (args[0]))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1902 args[0] = make_int (XCHAR (args[0]));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1903 else if (MARKERP (args[0]))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1904 args[0] = make_int (marker_position (args[0]));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1905 for (i = 1; i < nargs; i++)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1906 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1907 comp1 = args[minindex];
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1908 comp2 = args[i];
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1909 switch (promote_args (&comp1, &comp2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1910 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1911 case FIXNUM_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1912 if (XREALINT (comp1) > XREALINT (comp2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1913 minindex = i;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1914 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1915 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1916 case BIGNUM_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1917 if (bignum_gt (XBIGNUM_DATA (comp1), XBIGNUM_DATA (comp2)))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1918 minindex = i;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1919 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1920 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1921 #ifdef HAVE_RATIO
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1922 case RATIO_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1923 if (ratio_gt (XRATIO_DATA (comp1), XRATIO_DATA (comp2)))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1924 minindex = i;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1925 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1926 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1927 case FLOAT_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1928 if (XFLOAT_DATA (comp1) > XFLOAT_DATA (comp2))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1929 minindex = i;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1930 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1931 #ifdef HAVE_BIGFLOAT
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1932 case BIGFLOAT_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1933 if (bigfloat_gt (XBIGFLOAT_DATA (comp1), XBIGFLOAT_DATA (comp2)))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1934 minindex = i;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1935 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1936 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1937 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1938 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1939 return args[minindex];
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1940 #else /* !WITH_NUMBER_TYPES */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1941 EMACS_INT imin;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1942 double dmin;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1943 Lisp_Object *args_end = args + nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1944 int_or_double iod;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1945
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1946 number_char_or_marker_to_int_or_double (*args++, &iod);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1947 if (iod.int_p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1948 imin = iod.c.ival;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1949 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1950 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1951 dmin = iod.c.dval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1952 goto min_floats;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1953 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1954
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1955 while (args < args_end)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1956 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1957 number_char_or_marker_to_int_or_double (*args++, &iod);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1958 if (iod.int_p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1959 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1960 if (imin > iod.c.ival) imin = iod.c.ival;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1961 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1962 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1963 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1964 dmin = (double) imin;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1965 if (dmin > iod.c.dval) dmin = iod.c.dval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1966 goto min_floats;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1967 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1968 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1969
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1970 return make_int (imin);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1971
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1972 min_floats:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1973 while (args < args_end)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1974 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1975 double dval = number_char_or_marker_to_double (*args++);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1976 if (dmin > dval) dmin = dval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1977 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1978 return make_float (dmin);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1979 #endif /* WITH_NUMBER_TYPES */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1980 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1981
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1982 DEFUN ("logand", Flogand, 0, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1983 Return bitwise-and of all the arguments.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1984 Arguments may be integers, or markers or characters converted to integers.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1985 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1986 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
1987 {
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1988 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1989 REGISTER int i;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1990 Lisp_Object result, other;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1991
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1992 if (nargs == 0)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1993 return make_int (~0);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1994
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1995 while (!(CHARP (args[0]) || MARKERP (args[0]) || INTEGERP (args[0])))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1996 args[0] = wrong_type_argument (Qnumber_char_or_marker_p, args[0]);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1997
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1998 result = args[0];
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
1999 if (CHARP (result))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2000 result = make_int (XCHAR (result));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2001 else if (MARKERP (result))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2002 result = make_int (marker_position (result));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2003 for (i = 1; i < nargs; i++)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2004 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2005 while (!(CHARP (args[i]) || MARKERP (args[i]) || INTEGERP (args[i])))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2006 args[i] = wrong_type_argument (Qnumber_char_or_marker_p, args[i]);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2007 other = args[i];
1995
4e6a63799f08 [xemacs-hg @ 2004-04-07 03:48:58 by james]
james
parents: 1994
diff changeset
2008 switch (promote_args (&result, &other))
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2009 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2010 case FIXNUM_T:
1995
4e6a63799f08 [xemacs-hg @ 2004-04-07 03:48:58 by james]
james
parents: 1994
diff changeset
2011 result = make_int (XREALINT (result) & XREALINT (other));
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2012 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2013 case BIGNUM_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2014 bignum_and (scratch_bignum, XBIGNUM_DATA (result),
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2015 XBIGNUM_DATA (other));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2016 result = make_bignum_bg (scratch_bignum);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2017 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2018 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2019 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2020 return Fcanonicalize_number (result);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2021 #else /* !HAVE_BIGNUM */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2022 EMACS_INT bits = ~0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2023 Lisp_Object *args_end = args + nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2024
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2025 while (args < args_end)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2026 bits &= integer_char_or_marker_to_int (*args++);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2027
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2028 return make_int (bits);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2029 #endif /* HAVE_BIGNUM */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2030 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2031
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2032 DEFUN ("logior", Flogior, 0, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2033 Return bitwise-or of all the arguments.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2034 Arguments may be integers, or markers or characters converted to integers.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2035 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2036 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2037 {
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2038 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2039 REGISTER int i;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2040 Lisp_Object result, other;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2041
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2042 if (nargs == 0)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2043 return make_int (0);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2044
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2045 while (!(CHARP (args[0]) || MARKERP (args[0]) || INTEGERP (args[0])))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2046 args[0] = wrong_type_argument (Qnumber_char_or_marker_p, args[0]);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2047
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2048 result = args[0];
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2049 if (CHARP (result))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2050 result = make_int (XCHAR (result));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2051 else if (MARKERP (result))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2052 result = make_int (marker_position (result));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2053 for (i = 1; i < nargs; i++)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2054 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2055 while (!(CHARP (args[i]) || MARKERP (args[i]) || INTEGERP (args[i])))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2056 args[i] = wrong_type_argument (Qnumber_char_or_marker_p, args[i]);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2057 other = args[i];
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2058 switch (promote_args (&result, &other))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2059 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2060 case FIXNUM_T:
1992
4529ff71e646 [xemacs-hg @ 2004-04-07 02:20:12 by james]
james
parents: 1983
diff changeset
2061 result = make_int (XREALINT (result) | XREALINT (other));
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2062 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2063 case BIGNUM_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2064 bignum_ior (scratch_bignum, XBIGNUM_DATA (result),
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2065 XBIGNUM_DATA (other));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2066 result = make_bignum_bg (scratch_bignum);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2067 break;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2068 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2069 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2070 return Fcanonicalize_number (result);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2071 #else /* !HAVE_BIGNUM */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2072 EMACS_INT bits = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2073 Lisp_Object *args_end = args + nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2074
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2075 while (args < args_end)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2076 bits |= integer_char_or_marker_to_int (*args++);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2077
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2078 return make_int (bits);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2079 #endif /* HAVE_BIGNUM */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2080 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2081
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2082 DEFUN ("logxor", Flogxor, 0, MANY, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2083 Return bitwise-exclusive-or of all the arguments.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2084 Arguments may be integers, or markers or characters converted to integers.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2085 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2086 (int nargs, Lisp_Object *args))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2087 {
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2088 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2089 REGISTER int i;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2090 Lisp_Object result, other;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2091
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2092 if (nargs == 0)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2093 return make_int (0);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2094
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2095 while (!(CHARP (args[0]) || MARKERP (args[0]) || INTEGERP (args[0])))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2096 args[0] = wrong_type_argument (Qnumber_char_or_marker_p, args[0]);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2097
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2098 result = args[0];
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2099 if (CHARP (result))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2100 result = make_int (XCHAR (result));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2101 else if (MARKERP (result))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2102 result = make_int (marker_position (result));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2103 for (i = 1; i < nargs; i++)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2104 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2105 while (!(CHARP (args[i]) || MARKERP (args[i]) || INTEGERP (args[i])))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2106 args[i] = wrong_type_argument (Qnumber_char_or_marker_p, args[i]);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2107 other = args[i];
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2108 if (promote_args (&result, &other) == FIXNUM_T)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2109 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2110 result = make_int (XREALINT (result) ^ XREALINT (other));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2111 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2112 else
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2113 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2114 bignum_xor (scratch_bignum, XBIGNUM_DATA (result),
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2115 XBIGNUM_DATA (other));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2116 result = make_bignum_bg (scratch_bignum);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2117 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2118 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2119 return Fcanonicalize_number (result);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2120 #else /* !HAVE_BIGNUM */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2121 EMACS_INT bits = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2122 Lisp_Object *args_end = args + nargs;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2123
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2124 while (args < args_end)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2125 bits ^= integer_char_or_marker_to_int (*args++);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2126
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2127 return make_int (bits);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2128 #endif /* !HAVE_BIGNUM */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2129 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2130
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2131 DEFUN ("lognot", Flognot, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2132 Return the bitwise complement of NUMBER.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2133 NUMBER may be an integer, marker or character converted to integer.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2134 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2135 (number))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2136 {
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2137 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2138 if (BIGNUMP (number))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2139 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2140 bignum_not (scratch_bignum, XBIGNUM_DATA (number));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2141 return make_bignum_bg (scratch_bignum);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2142 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2143 #endif /* HAVE_BIGNUM */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2144 return make_int (~ integer_char_or_marker_to_int (number));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2145 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2146
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2147 DEFUN ("%", Frem, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2148 Return remainder of first arg divided by second.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2149 Both must be integers, characters or markers.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2150 */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2151 (number1, number2))
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2152 {
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2153 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2154 while (!(CHARP (number1) || MARKERP (number1) || INTEGERP (number1)))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2155 number1 = wrong_type_argument (Qnumber_char_or_marker_p, number1);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2156 while (!(CHARP (number2) || MARKERP (number2) || INTEGERP (number2)))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2157 number2 = wrong_type_argument (Qnumber_char_or_marker_p, number2);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2158
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2159 if (promote_args (&number1, &number2) == FIXNUM_T)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2160 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2161 if (XREALINT (number2) == 0)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2162 Fsignal (Qarith_error, Qnil);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2163 return make_int (XREALINT (number1) % XREALINT (number2));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2164 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2165 else
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2166 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2167 if (bignum_sign (XBIGNUM_DATA (number2)) == 0)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2168 Fsignal (Qarith_error, Qnil);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2169 bignum_mod (scratch_bignum, XBIGNUM_DATA (number1),
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2170 XBIGNUM_DATA (number2));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2171 return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2172 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2173 #else /* !HAVE_BIGNUM */
444
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2174 EMACS_INT ival1 = integer_char_or_marker_to_int (number1);
576fb035e263 Import from CVS: tag r21-2-37
cvs
parents: 442
diff changeset
2175 EMACS_INT ival2 = integer_char_or_marker_to_int (number2);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2176
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2177 if (ival2 == 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2178 Fsignal (Qarith_error, Qnil);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2179
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2180 return make_int (ival1 % ival2);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2181 #endif /* HAVE_BIGNUM */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2182 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2183
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2184 /* Note, ANSI *requires* the presence of the fmod() library routine.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2185 If your system doesn't have it, complain to your vendor, because
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2186 that is a bug. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2187
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2188 #ifndef HAVE_FMOD
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2189 double
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2190 fmod (double f1, double f2)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2191 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2192 if (f2 < 0.0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2193 f2 = -f2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2194 return f1 - f2 * floor (f1/f2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2195 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2196 #endif /* ! HAVE_FMOD */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2197
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2198
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2199 DEFUN ("mod", Fmod, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2200 Return X modulo Y.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2201 The result falls between zero (inclusive) and Y (exclusive).
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2202 Both X and Y must be numbers, characters or markers.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2203 If either argument is a float, a float will be returned.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2204 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2205 (x, y))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2206 {
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2207 #ifdef WITH_NUMBER_TYPES
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2208 while (!(CHARP (x) || MARKERP (x) || REALP (x)))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2209 x = wrong_type_argument (Qnumber_char_or_marker_p, x);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2210 while (!(CHARP (y) || MARKERP (y) || REALP (y)))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2211 y = wrong_type_argument (Qnumber_char_or_marker_p, y);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2212 switch (promote_args (&x, &y))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2213 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2214 case FIXNUM_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2215 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2216 EMACS_INT ival;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2217 if (XREALINT (y) == 0) goto divide_by_zero;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2218 ival = XREALINT (x) % XREALINT (y);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2219 /* If the "remainder" comes out with the wrong sign, fix it. */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2220 if (XREALINT (y) < 0 ? ival > 0 : ival < 0)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2221 ival += XREALINT (y);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2222 return make_int (ival);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2223 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2224 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2225 case BIGNUM_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2226 if (bignum_sign (XBIGNUM_DATA (y)) == 0) goto divide_by_zero;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2227 bignum_mod (scratch_bignum, XBIGNUM_DATA (x), XBIGNUM_DATA (y));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2228 return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2229 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2230 #ifdef HAVE_RATIO
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2231 case RATIO_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2232 if (ratio_sign (XRATIO_DATA (y)) == 0) goto divide_by_zero;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2233 ratio_div (scratch_ratio, XRATIO_DATA (x), XRATIO_DATA (y));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2234 bignum_div (scratch_bignum, ratio_numerator (scratch_ratio),
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2235 ratio_denominator (scratch_ratio));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2236 ratio_set_bignum (scratch_ratio, scratch_bignum);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2237 ratio_mul (scratch_ratio, scratch_ratio, XRATIO_DATA (y));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2238 ratio_sub (scratch_ratio, XRATIO_DATA (x), scratch_ratio);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2239 return Fcanonicalize_number (make_ratio_rt (scratch_ratio));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2240 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2241 case FLOAT_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2242 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2243 double dval;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2244 if (XFLOAT_DATA (y) == 0.0) goto divide_by_zero;
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2245 dval = fmod (XFLOAT_DATA (x), XFLOAT_DATA (y));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2246 /* If the "remainder" comes out with the wrong sign, fix it. */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2247 if (XFLOAT_DATA (y) < 0 ? dval > 0 : dval < 0)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2248 dval += XFLOAT_DATA (y);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2249 return make_float (dval);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2250 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2251 #ifdef HAVE_BIGFLOAT
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2252 case BIGFLOAT_T:
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2253 bigfloat_set_prec (scratch_bigfloat,
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2254 max (XBIGFLOAT_GET_PREC (x), XBIGFLOAT_GET_PREC (y)));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2255 bigfloat_div (scratch_bigfloat, XBIGFLOAT_DATA (x), XBIGFLOAT_DATA (y));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2256 bigfloat_trunc (scratch_bigfloat, scratch_bigfloat);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2257 bigfloat_mul (scratch_bigfloat, scratch_bigfloat, XBIGFLOAT_DATA (y));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2258 bigfloat_sub (scratch_bigfloat, XBIGFLOAT_DATA (x), scratch_bigfloat);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2259 return make_bigfloat_bf (scratch_bigfloat);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2260 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2261 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2262 #else /* !WITH_NUMBER_TYPES */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2263 int_or_double iod1, iod2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2264 number_char_or_marker_to_int_or_double (x, &iod1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2265 number_char_or_marker_to_int_or_double (y, &iod2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2266
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2267 if (!iod1.int_p || !iod2.int_p)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2268 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2269 double dval1 = iod1.int_p ? (double) iod1.c.ival : iod1.c.dval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2270 double dval2 = iod2.int_p ? (double) iod2.c.ival : iod2.c.dval;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2271 if (dval2 == 0) goto divide_by_zero;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2272 dval1 = fmod (dval1, dval2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2273
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2274 /* If the "remainder" comes out with the wrong sign, fix it. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2275 if (dval2 < 0 ? dval1 > 0 : dval1 < 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2276 dval1 += dval2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2277
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2278 return make_float (dval1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2279 }
1104
8b464283e891 [xemacs-hg @ 2002-11-12 18:58:13 by james]
james
parents: 993
diff changeset
2280
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2281 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2282 EMACS_INT ival;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2283 if (iod2.c.ival == 0) goto divide_by_zero;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2284
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2285 ival = iod1.c.ival % iod2.c.ival;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2286
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2287 /* If the "remainder" comes out with the wrong sign, fix it. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2288 if (iod2.c.ival < 0 ? ival > 0 : ival < 0)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2289 ival += iod2.c.ival;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2290
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2291 return make_int (ival);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2292 }
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2293 #endif /* WITH_NUMBER_TYPES */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2294
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2295 divide_by_zero:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2296 Fsignal (Qarith_error, Qnil);
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
2297 return Qnil; /* not (usually) reached */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2298 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2299
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2300 DEFUN ("ash", Fash, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2301 Return VALUE with its bits shifted left by COUNT.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2302 If COUNT is negative, shifting is actually to the right.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2303 In this case, the sign bit is duplicated.
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2304 This function cannot be applied to bignums, as there is no leftmost sign bit
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2305 to be duplicated. Use `lsh' instead.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2306 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2307 (value, count))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2308 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2309 CHECK_INT_COERCE_CHAR (value);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2310 CONCHECK_INT (count);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2311
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2312 return make_int (XINT (count) > 0 ?
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2313 XINT (value) << XINT (count) :
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2314 XINT (value) >> -XINT (count));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2315 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2316
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2317 DEFUN ("lsh", Flsh, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2318 Return VALUE with its bits shifted left by COUNT.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2319 If COUNT is negative, shifting is actually to the right.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2320 In this case, zeros are shifted in on the left.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2321 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2322 (value, count))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2323 {
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2324 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2325 while (!(CHARP (value) || MARKERP (value) || INTEGERP (value)))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2326 wrong_type_argument (Qnumber_char_or_marker_p, value);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2327 CONCHECK_INTEGER (count);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2328
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2329 if (promote_args (&value, &count) == FIXNUM_T)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2330 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2331 if (XREALINT (count) <= 0)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2332 return make_int (XREALINT (value) >> -XREALINT (count));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2333 /* Use bignums to avoid overflow */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2334 bignum_set_long (scratch_bignum2, XREALINT (value));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2335 bignum_lshift (scratch_bignum, scratch_bignum2, XREALINT (count));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2336 return Fcanonicalize_number (make_bignum_bg (scratch_bignum));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2337 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2338 else
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2339 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2340 if (bignum_sign (XBIGNUM_DATA (count)) <= 0)
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2341 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2342 bignum_neg (scratch_bignum, XBIGNUM_DATA (count));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2343 if (!bignum_fits_ulong_p (scratch_bignum))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2344 args_out_of_range (Qnumber_char_or_marker_p, count);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2345 bignum_rshift (scratch_bignum2, XBIGNUM_DATA (value),
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2346 bignum_to_ulong (scratch_bignum));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2347 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2348 else
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2349 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2350 if (!bignum_fits_ulong_p (XBIGNUM_DATA (count)))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2351 args_out_of_range (Qnumber_char_or_marker_p, count);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2352 bignum_lshift (scratch_bignum2, XBIGNUM_DATA (value),
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2353 bignum_to_ulong (XBIGNUM_DATA (count)));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2354 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2355 return Fcanonicalize_number (make_bignum_bg (scratch_bignum2));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2356 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2357 #else /* !HAVE_BIGNUM */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2358 CHECK_INT_COERCE_CHAR (value);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2359 CONCHECK_INT (count);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2360
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2361 return make_int (XINT (count) > 0 ?
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2362 XUINT (value) << XINT (count) :
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2363 XUINT (value) >> -XINT (count));
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2364 #endif /* HAVE_BIGNUM */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2365 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2366
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2367 DEFUN ("1+", Fadd1, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2368 Return NUMBER plus one. NUMBER may be a number, character or marker.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2369 Markers and characters are converted to integers.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2370 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2371 (number))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2372 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2373 retry:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2374
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2375 if (INTP (number)) return make_integer (XINT (number) + 1);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2376 if (CHARP (number)) return make_integer (XCHAR (number) + 1);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2377 if (MARKERP (number)) return make_integer (marker_position (number) + 1);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2378 if (FLOATP (number)) return make_float (XFLOAT_DATA (number) + 1.0);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2379 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2380 if (BIGNUMP (number))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2381 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2382 bignum_set_long (scratch_bignum, 1L);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2383 bignum_add (scratch_bignum2, XBIGNUM_DATA (number), scratch_bignum);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2384 return Fcanonicalize_number (make_bignum_bg (scratch_bignum2));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2385 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2386 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2387 #ifdef HAVE_RATIO
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2388 if (RATIOP (number))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2389 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2390 ratio_set_long (scratch_ratio, 1L);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2391 ratio_add (scratch_ratio, XRATIO_DATA (number), scratch_ratio);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2392 /* No need to canonicalize after adding 1 */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2393 return make_ratio_rt (scratch_ratio);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2394 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2395 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2396 #ifdef HAVE_BIGFLOAT
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2397 if (BIGFLOATP (number))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2398 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2399 bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2400 bigfloat_set_long (scratch_bigfloat, 1L);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2401 bigfloat_add (scratch_bigfloat, XBIGFLOAT_DATA (number),
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2402 scratch_bigfloat);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2403 return make_bigfloat_bf (scratch_bigfloat);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2404 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2405 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2406
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2407 number = wrong_type_argument (Qnumber_char_or_marker_p, number);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2408 goto retry;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2409 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2410
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2411 DEFUN ("1-", Fsub1, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2412 Return NUMBER minus one. NUMBER may be a number, character or marker.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2413 Markers and characters are converted to integers.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2414 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2415 (number))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2416 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2417 retry:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2418
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2419 if (INTP (number)) return make_integer (XINT (number) - 1);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2420 if (CHARP (number)) return make_integer (XCHAR (number) - 1);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2421 if (MARKERP (number)) return make_integer (marker_position (number) - 1);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2422 if (FLOATP (number)) return make_float (XFLOAT_DATA (number) - 1.0);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2423 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2424 if (BIGNUMP (number))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2425 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2426 bignum_set_long (scratch_bignum, 1L);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2427 bignum_sub (scratch_bignum2, XBIGNUM_DATA (number), scratch_bignum);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2428 return Fcanonicalize_number (make_bignum_bg (scratch_bignum2));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2429 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2430 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2431 #ifdef HAVE_RATIO
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2432 if (RATIOP (number))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2433 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2434 ratio_set_long (scratch_ratio, 1L);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2435 ratio_sub (scratch_ratio, XRATIO_DATA (number), scratch_ratio);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2436 /* No need to canonicalize after subtracting 1 */
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2437 return make_ratio_rt (scratch_ratio);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2438 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2439 #endif
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2440 #ifdef HAVE_BIGFLOAT
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2441 if (BIGFLOATP (number))
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2442 {
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2443 bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number));
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2444 bigfloat_set_long (scratch_bigfloat, 1L);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2445 bigfloat_sub (scratch_bigfloat, XBIGFLOAT_DATA (number),
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2446 scratch_bigfloat);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2447 return make_bigfloat_bf (scratch_bigfloat);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2448 }
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
2449 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2450
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2451 number = wrong_type_argument (Qnumber_char_or_marker_p, number);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2452 goto retry;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2453 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2454
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2455
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2456 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2457 /* weak lists */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2458 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2459
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2460 /* A weak list is like a normal list except that elements automatically
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2461 disappear when no longer in use, i.e. when no longer GC-protected.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2462 The basic idea is that we don't mark the elements during GC, but
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2463 wait for them to be marked elsewhere. If they're not marked, we
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2464 remove them. This is analogous to weak hash tables; see the explanation
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2465 there for more info. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2466
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2467 static Lisp_Object Vall_weak_lists; /* Gemarke es nicht!!! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2468
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2469 static Lisp_Object encode_weak_list_type (enum weak_list_type type);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2470
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2471 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2472 mark_weak_list (Lisp_Object obj)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2473 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2474 return Qnil; /* nichts ist gemarkt */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2475 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2476
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2477 static void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2478 print_weak_list (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2479 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2480 if (print_readably)
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 458
diff changeset
2481 printing_unreadable_object ("#<weak-list>");
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2482
800
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
2483 write_fmt_string_lisp (printcharfun, "#<weak-list %s %S>", 2,
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
2484 encode_weak_list_type (XWEAK_LIST (obj)->type),
a5954632b187 [xemacs-hg @ 2002-03-31 08:27:14 by ben]
ben
parents: 793
diff changeset
2485 XWEAK_LIST (obj)->list);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2486 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2487
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2488 static int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2489 weak_list_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2490 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2491 struct weak_list *w1 = XWEAK_LIST (obj1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2492 struct weak_list *w2 = XWEAK_LIST (obj2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2493
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2494 return ((w1->type == w2->type) &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2495 internal_equal (w1->list, w2->list, depth + 1));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2496 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2497
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2498 static Hashcode
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2499 weak_list_hash (Lisp_Object obj, int depth)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2500 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2501 struct weak_list *w = XWEAK_LIST (obj);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2502
665
fdefd0186b75 [xemacs-hg @ 2001-09-20 06:28:42 by ben]
ben
parents: 647
diff changeset
2503 return HASH2 ((Hashcode) w->type,
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2504 internal_hash (w->list, depth + 1));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2505 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2506
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2507 Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2508 make_weak_list (enum weak_list_type type)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2509 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2510 Lisp_Object result;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2511 struct weak_list *wl =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2512 alloc_lcrecord_type (struct weak_list, &lrecord_weak_list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2513
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2514 wl->list = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2515 wl->type = type;
793
e38acbeb1cae [xemacs-hg @ 2002-03-29 04:46:17 by ben]
ben
parents: 771
diff changeset
2516 result = wrap_weak_list (wl);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2517 wl->next_weak = Vall_weak_lists;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2518 Vall_weak_lists = result;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2519 return result;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2520 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2521
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1104
diff changeset
2522 static const struct memory_description weak_list_description[] = {
1598
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
2523 { XD_LISP_OBJECT, offsetof (struct weak_list, list),
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
2524 0, 0, XD_FLAG_NO_KKCC },
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
2525 { XD_LO_LINK, offsetof (struct weak_list, next_weak),
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
2526 0, 0, XD_FLAG_NO_KKCC },
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2527 { XD_END }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2528 };
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2529
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 888
diff changeset
2530 DEFINE_LRECORD_IMPLEMENTATION ("weak-list", weak_list,
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 888
diff changeset
2531 1, /*dumpable-flag*/
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 888
diff changeset
2532 mark_weak_list, print_weak_list,
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 888
diff changeset
2533 0, weak_list_equal, weak_list_hash,
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 888
diff changeset
2534 weak_list_description,
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 888
diff changeset
2535 struct weak_list);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2536 /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2537 -- we do not mark the list elements (either the elements themselves
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2538 or the cons cells that hold them) in the normal marking phase.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2539 -- at the end of marking, we go through all weak lists that are
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2540 marked, and mark the cons cells that hold all marked
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2541 objects, and possibly parts of the objects themselves.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2542 (See alloc.c, "after-mark".)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2543 -- after that, we prune away all the cons cells that are not marked.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2544
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2545 WARNING WARNING WARNING WARNING WARNING:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2546
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2547 The code in the following two functions is *unbelievably* tricky.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2548 Don't mess with it. You'll be sorry.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2549
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2550 Linked lists just majorly suck, d'ya know?
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2551 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2552
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2553 int
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2554 finish_marking_weak_lists (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2555 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2556 Lisp_Object rest;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2557 int did_mark = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2558
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2559 for (rest = Vall_weak_lists;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2560 !NILP (rest);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2561 rest = XWEAK_LIST (rest)->next_weak)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2562 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2563 Lisp_Object rest2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2564 enum weak_list_type type = XWEAK_LIST (rest)->type;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2565
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2566 if (! marked_p (rest))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2567 /* The weak list is probably garbage. Ignore it. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2568 continue;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2569
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2570 for (rest2 = XWEAK_LIST (rest)->list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2571 /* We need to be trickier since we're inside of GC;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2572 use CONSP instead of !NILP in case of user-visible
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2573 imperfect lists */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2574 CONSP (rest2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2575 rest2 = XCDR (rest2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2576 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2577 Lisp_Object elem;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2578 /* If the element is "marked" (meaning depends on the type
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2579 of weak list), we need to mark the cons containing the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2580 element, and maybe the element itself (if only some part
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2581 was already marked). */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2582 int need_to_mark_cons = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2583 int need_to_mark_elem = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2584
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2585 /* If a cons is already marked, then its car is already marked
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2586 (either because of an external pointer or because of
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2587 a previous call to this function), and likewise for all
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2588 the rest of the elements in the list, so we can stop now. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2589 if (marked_p (rest2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2590 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2591
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2592 elem = XCAR (rest2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2593
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2594 switch (type)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2595 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2596 case WEAK_LIST_SIMPLE:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2597 if (marked_p (elem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2598 need_to_mark_cons = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2599 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2600
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2601 case WEAK_LIST_ASSOC:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2602 if (!CONSP (elem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2603 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2604 /* just leave bogus elements there */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2605 need_to_mark_cons = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2606 need_to_mark_elem = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2607 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2608 else if (marked_p (XCAR (elem)) &&
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2609 marked_p (XCDR (elem)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2610 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2611 need_to_mark_cons = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2612 /* We still need to mark elem, because it's
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2613 probably not marked. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2614 need_to_mark_elem = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2615 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2616 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2617
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2618 case WEAK_LIST_KEY_ASSOC:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2619 if (!CONSP (elem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2620 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2621 /* just leave bogus elements there */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2622 need_to_mark_cons = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2623 need_to_mark_elem = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2624 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2625 else if (marked_p (XCAR (elem)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2626 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2627 need_to_mark_cons = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2628 /* We still need to mark elem and XCDR (elem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2629 marking elem does both */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2630 need_to_mark_elem = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2631 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2632 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2633
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2634 case WEAK_LIST_VALUE_ASSOC:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2635 if (!CONSP (elem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2636 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2637 /* just leave bogus elements there */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2638 need_to_mark_cons = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2639 need_to_mark_elem = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2640 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2641 else if (marked_p (XCDR (elem)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2642 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2643 need_to_mark_cons = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2644 /* We still need to mark elem and XCAR (elem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2645 marking elem does both */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2646 need_to_mark_elem = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2647 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2648 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2649
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2650 case WEAK_LIST_FULL_ASSOC:
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2651 if (!CONSP (elem))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2652 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2653 /* just leave bogus elements there */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2654 need_to_mark_cons = 1;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2655 need_to_mark_elem = 1;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2656 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2657 else if (marked_p (XCAR (elem)) ||
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2658 marked_p (XCDR (elem)))
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2659 {
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2660 need_to_mark_cons = 1;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2661 /* We still need to mark elem and XCAR (elem);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2662 marking elem does both */
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2663 need_to_mark_elem = 1;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2664 }
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2665 break;
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2666
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2667 default:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2668 abort ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2669 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2670
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2671 if (need_to_mark_elem && ! marked_p (elem))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2672 {
1598
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
2673 #ifdef USE_KKCC
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
2674 kkcc_gc_stack_push_lisp_object (elem);
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
2675 #else /* NOT USE_KKCC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2676 mark_object (elem);
1598
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
2677 #endif /* NOT USE_KKCC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2678 did_mark = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2679 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2680
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2681 /* We also need to mark the cons that holds the elem or
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2682 assoc-pair. We do *not* want to call (mark_object) here
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2683 because that will mark the entire list; we just want to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2684 mark the cons itself.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2685 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2686 if (need_to_mark_cons)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2687 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2688 Lisp_Cons *c = XCONS (rest2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2689 if (!CONS_MARKED_P (c))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2690 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2691 MARK_CONS (c);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2692 did_mark = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2693 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2694 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2695 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2696
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2697 /* In case of imperfect list, need to mark the final cons
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2698 because we're not removing it */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2699 if (!NILP (rest2) && ! marked_p (rest2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2700 {
1598
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
2701 #ifdef USE_KKCC
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
2702 kkcc_gc_stack_push_lisp_object (rest2);
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
2703 #else /* NOT USE_KKCC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2704 mark_object (rest2);
1598
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
2705 #endif /* NOT USE_KKCC */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2706 did_mark = 1;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2707 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2708 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2709
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2710 return did_mark;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2711 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2712
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2713 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2714 prune_weak_lists (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2715 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2716 Lisp_Object rest, prev = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2717
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2718 for (rest = Vall_weak_lists;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2719 !NILP (rest);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2720 rest = XWEAK_LIST (rest)->next_weak)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2721 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2722 if (! (marked_p (rest)))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2723 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2724 /* This weak list itself is garbage. Remove it from the list. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2725 if (NILP (prev))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2726 Vall_weak_lists = XWEAK_LIST (rest)->next_weak;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2727 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2728 XWEAK_LIST (prev)->next_weak =
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2729 XWEAK_LIST (rest)->next_weak;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2730 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2731 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2732 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2733 Lisp_Object rest2, prev2 = Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2734 Lisp_Object tortoise;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2735 int go_tortoise = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2736
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2737 for (rest2 = XWEAK_LIST (rest)->list, tortoise = rest2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2738 /* We need to be trickier since we're inside of GC;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2739 use CONSP instead of !NILP in case of user-visible
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2740 imperfect lists */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2741 CONSP (rest2);)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2742 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2743 /* It suffices to check the cons for marking,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2744 regardless of the type of weak list:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2745
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2746 -- if the cons is pointed to somewhere else,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2747 then it should stay around and will be marked.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2748 -- otherwise, if it should stay around, it will
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2749 have been marked in finish_marking_weak_lists().
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2750 -- otherwise, it's not marked and should disappear.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2751 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2752 if (! marked_p (rest2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2753 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2754 /* bye bye :-( */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2755 if (NILP (prev2))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2756 XWEAK_LIST (rest)->list = XCDR (rest2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2757 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2758 XCDR (prev2) = XCDR (rest2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2759 rest2 = XCDR (rest2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2760 /* Ouch. Circularity checking is even trickier
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2761 than I thought. When we cut out a link
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2762 like this, we can't advance the turtle or
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2763 it'll catch up to us. Imagine that we're
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2764 standing on floor tiles and moving forward --
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2765 what we just did here is as if the floor
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2766 tile under us just disappeared and all the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2767 ones ahead of us slid one tile towards us.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2768 In other words, we didn't move at all;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2769 if the tortoise was one step behind us
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2770 previously, it still is, and therefore
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2771 it must not move. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2772 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2773 else
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2774 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2775 prev2 = rest2;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2776
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2777 /* Implementing circularity checking is trickier here
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2778 than in other places because we have to guarantee
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2779 that we've processed all elements before exiting
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2780 due to a circularity. (In most places, an error
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2781 is issued upon encountering a circularity, so it
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2782 doesn't really matter if all elements are processed.)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2783 The idea is that we process along with the hare
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2784 rather than the tortoise. If at any point in
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2785 our forward process we encounter the tortoise,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2786 we must have already visited the spot, so we exit.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2787 (If we process with the tortoise, we can fail to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2788 process cases where a cons points to itself, or
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2789 where cons A points to cons B, which points to
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2790 cons A.) */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2791
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2792 rest2 = XCDR (rest2);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2793 if (go_tortoise)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2794 tortoise = XCDR (tortoise);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2795 go_tortoise = !go_tortoise;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2796 if (EQ (rest2, tortoise))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2797 break;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2798 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2799 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2800
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2801 prev = rest;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2802 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2803 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2804 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2805
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2806 static enum weak_list_type
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2807 decode_weak_list_type (Lisp_Object symbol)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2808 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2809 CHECK_SYMBOL (symbol);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2810 if (EQ (symbol, Qsimple)) return WEAK_LIST_SIMPLE;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2811 if (EQ (symbol, Qassoc)) return WEAK_LIST_ASSOC;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2812 if (EQ (symbol, Qold_assoc)) return WEAK_LIST_ASSOC; /* EBOLA ALERT! */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2813 if (EQ (symbol, Qkey_assoc)) return WEAK_LIST_KEY_ASSOC;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2814 if (EQ (symbol, Qvalue_assoc)) return WEAK_LIST_VALUE_ASSOC;
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2815 if (EQ (symbol, Qfull_assoc)) return WEAK_LIST_FULL_ASSOC;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2816
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 458
diff changeset
2817 invalid_constant ("Invalid weak list type", symbol);
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1104
diff changeset
2818 RETURN_NOT_REACHED (WEAK_LIST_SIMPLE);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2819 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2820
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2821 static Lisp_Object
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2822 encode_weak_list_type (enum weak_list_type type)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2823 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2824 switch (type)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2825 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2826 case WEAK_LIST_SIMPLE: return Qsimple;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2827 case WEAK_LIST_ASSOC: return Qassoc;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2828 case WEAK_LIST_KEY_ASSOC: return Qkey_assoc;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2829 case WEAK_LIST_VALUE_ASSOC: return Qvalue_assoc;
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2830 case WEAK_LIST_FULL_ASSOC: return Qfull_assoc;
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2831 default:
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2832 abort ();
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2833 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2834
801
2b676dc88c66 [xemacs-hg @ 2002-04-01 03:58:02 by ben]
ben
parents: 800
diff changeset
2835 return Qnil; /* not (usually) reached */
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2836 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2837
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2838 DEFUN ("weak-list-p", Fweak_list_p, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2839 Return non-nil if OBJECT is a weak list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2840 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2841 (object))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2842 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2843 return WEAK_LISTP (object) ? Qt : Qnil;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2844 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2845
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2846 DEFUN ("make-weak-list", Fmake_weak_list, 0, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2847 Return a new weak list object of type TYPE.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2848 A weak list object is an object that contains a list. This list behaves
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2849 like any other list except that its elements do not count towards
456
e7ef97881643 Import from CVS: tag r21-2-43
cvs
parents: 452
diff changeset
2850 garbage collection -- if the only pointer to an object is inside a weak
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2851 list (other than pointers in similar objects such as weak hash tables),
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2852 the object is garbage collected and automatically removed from the list.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2853 This is used internally, for example, to manage the list holding the
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2854 children of an extent -- an extent that is unused but has a parent will
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2855 still be reclaimed, and will automatically be removed from its parent's
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2856 list of children.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2857
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2858 Optional argument TYPE specifies the type of the weak list, and defaults
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2859 to `simple'. Recognized types are
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2860
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2861 `simple' Objects in the list disappear if not pointed to.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2862 `assoc' Objects in the list disappear if they are conses
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2863 and either the car or the cdr of the cons is not
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2864 pointed to.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2865 `key-assoc' Objects in the list disappear if they are conses
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2866 and the car is not pointed to.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2867 `value-assoc' Objects in the list disappear if they are conses
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2868 and the cdr is not pointed to.
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2869 `full-assoc' Objects in the list disappear if they are conses
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
2870 and neither the car nor the cdr is pointed to.
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2871 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2872 (type))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2873 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2874 if (NILP (type))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2875 type = Qsimple;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2876
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2877 return make_weak_list (decode_weak_list_type (type));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2878 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2879
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2880 DEFUN ("weak-list-type", Fweak_list_type, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2881 Return the type of the given weak-list object.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2882 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2883 (weak))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2884 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2885 CHECK_WEAK_LIST (weak);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2886 return encode_weak_list_type (XWEAK_LIST (weak)->type);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2887 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2888
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2889 DEFUN ("weak-list-list", Fweak_list_list, 1, 1, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2890 Return the list contained in a weak-list object.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2891 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2892 (weak))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2893 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2894 CHECK_WEAK_LIST (weak);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2895 return XWEAK_LIST_LIST (weak);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2896 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2897
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2898 DEFUN ("set-weak-list-list", Fset_weak_list_list, 2, 2, 0, /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2899 Change the list contained in a weak-list object.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2900 */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2901 (weak, new_list))
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2902 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2903 CHECK_WEAK_LIST (weak);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2904 XWEAK_LIST_LIST (weak) = new_list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2905 return new_list;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2906 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
2907
888
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
2908
858
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2909 /************************************************************************/
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2910 /* weak boxes */
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2911 /************************************************************************/
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2912
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2913 static Lisp_Object Vall_weak_boxes; /* Gemarke es niemals ever!!! */
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2914
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2915 void
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2916 prune_weak_boxes (void)
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2917 {
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2918 Lisp_Object rest, prev = Qnil;
888
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
2919 int removep = 0;
858
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2920
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2921 for (rest = Vall_weak_boxes;
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2922 !NILP(rest);
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2923 rest = XWEAK_BOX (rest)->next_weak_box)
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2924 {
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2925 if (! (marked_p (rest)))
888
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
2926 /* This weak box itself is garbage. */
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
2927 removep = 1;
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
2928
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
2929 if (! marked_p (XWEAK_BOX (rest)->value))
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
2930 {
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
2931 XSET_WEAK_BOX (rest, Qnil);
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
2932 removep = 1;
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
2933 }
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
2934
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
2935 if (removep)
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
2936 {
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
2937 /* Remove weak box from list. */
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
2938 if (NILP (prev))
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
2939 Vall_weak_boxes = XWEAK_BOX (rest)->next_weak_box;
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
2940 else
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
2941 XWEAK_BOX (prev)->next_weak_box = XWEAK_BOX (rest)->next_weak_box;
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
2942 removep = 0;
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
2943 }
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
2944 else
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
2945 prev = rest;
858
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2946 }
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2947 }
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2948
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2949 static Lisp_Object
888
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
2950 mark_weak_box (Lisp_Object obj)
858
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2951 {
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2952 return Qnil;
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2953 }
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2954
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2955 static void
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2956 print_weak_box (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2957 {
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2958 if (print_readably)
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2959 printing_unreadable_object ("#<weak_box>");
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2960 write_fmt_string (printcharfun, "#<weak_box>");
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2961 }
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2962
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2963 static int
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2964 weak_box_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2965 {
888
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
2966 struct weak_box *wb1 = XWEAK_BOX (obj1);
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
2967 struct weak_box *wb2 = XWEAK_BOX (obj2);
858
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2968
888
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
2969 return (internal_equal (wb1->value, wb2->value, depth + 1));
858
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2970 }
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2971
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2972 static Hashcode
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2973 weak_box_hash (Lisp_Object obj, int depth)
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2974 {
888
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
2975 struct weak_box *wb = XWEAK_BOX (obj);
858
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2976
888
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
2977 return internal_hash (wb->value, depth + 1);
858
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2978 }
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2979
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2980 Lisp_Object
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2981 make_weak_box (Lisp_Object value)
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2982 {
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2983 Lisp_Object result;
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2984
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2985 struct weak_box *wb =
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2986 alloc_lcrecord_type (struct weak_box, &lrecord_weak_box);
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2987
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2988 wb->value = value;
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2989 result = wrap_weak_box (wb);
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2990 wb->next_weak_box = Vall_weak_boxes;
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2991 Vall_weak_boxes = result;
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2992 return result;
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2993 }
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2994
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1104
diff changeset
2995 static const struct memory_description weak_box_description[] = {
858
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2996 { XD_LO_LINK, offsetof (struct weak_box, value) },
888
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
2997 { XD_END}
858
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2998 };
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
2999
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 888
diff changeset
3000 DEFINE_LRECORD_IMPLEMENTATION ("weak_box", weak_box,
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 888
diff changeset
3001 0, /*dumpable-flag*/
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 888
diff changeset
3002 mark_weak_box, print_weak_box,
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 888
diff changeset
3003 0, weak_box_equal, weak_box_hash,
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 888
diff changeset
3004 weak_box_description,
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 888
diff changeset
3005 struct weak_box);
858
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
3006
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
3007 DEFUN ("make-weak-box", Fmake_weak_box, 1, 1, 0, /*
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
3008 Return a new weak box from value CONTENTS.
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
3009 The weak box is a reference to CONTENTS which may be extracted with
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
3010 `weak-box-ref'. However, the weak box does not contribute to the
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
3011 reachability of CONTENTS. When CONTENTS is garbage-collected,
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
3012 `weak-box-ref' will return NIL.
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
3013 */
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
3014 (value))
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
3015 {
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
3016 return make_weak_box(value);
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
3017 }
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
3018
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
3019 DEFUN ("weak-box-ref", Fweak_box_ref, 1, 1, 0, /*
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
3020 Return the contents of weak box WEAK-BOX.
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
3021 If the contents have been GCed, return NIL.
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
3022 */
888
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3023 (wb))
858
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
3024 {
888
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3025 return XWEAK_BOX (wb)->value;
858
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
3026 }
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
3027
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
3028 DEFUN ("weak-box-p", Fweak_boxp, 1, 1, 0, /*
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
3029 Return non-nil if OBJECT is a weak box.
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
3030 */
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
3031 (object))
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
3032 {
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
3033 return WEAK_BOXP (object) ? Qt : Qnil;
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
3034 }
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
3035
888
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3036 /************************************************************************/
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3037 /* ephemerons */
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3038 /************************************************************************/
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3039
993
86012f228185 [xemacs-hg @ 2002-09-03 11:00:10 by michaels]
michaels
parents: 934
diff changeset
3040 /* The concept of ephemerons is due to:
86012f228185 [xemacs-hg @ 2002-09-03 11:00:10 by michaels]
michaels
parents: 934
diff changeset
3041 * Barry Hayes: Ephemerons: A New Finalization Mechanism. OOPSLA 1997: 176-183
86012f228185 [xemacs-hg @ 2002-09-03 11:00:10 by michaels]
michaels
parents: 934
diff changeset
3042 * The original idea is due to George Bosworth of Digitalk, Inc.
86012f228185 [xemacs-hg @ 2002-09-03 11:00:10 by michaels]
michaels
parents: 934
diff changeset
3043 *
86012f228185 [xemacs-hg @ 2002-09-03 11:00:10 by michaels]
michaels
parents: 934
diff changeset
3044 * For a discussion of finalization and weakness that also reviews
86012f228185 [xemacs-hg @ 2002-09-03 11:00:10 by michaels]
michaels
parents: 934
diff changeset
3045 * ephemerons, refer to:
86012f228185 [xemacs-hg @ 2002-09-03 11:00:10 by michaels]
michaels
parents: 934
diff changeset
3046 * Simon Peyton Jones, Simon Marlow, Conal Elliot:
86012f228185 [xemacs-hg @ 2002-09-03 11:00:10 by michaels]
michaels
parents: 934
diff changeset
3047 * Stretching the storage manager
86012f228185 [xemacs-hg @ 2002-09-03 11:00:10 by michaels]
michaels
parents: 934
diff changeset
3048 * Implementation of Functional Languages, 1999
86012f228185 [xemacs-hg @ 2002-09-03 11:00:10 by michaels]
michaels
parents: 934
diff changeset
3049 */
86012f228185 [xemacs-hg @ 2002-09-03 11:00:10 by michaels]
michaels
parents: 934
diff changeset
3050
888
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3051 static Lisp_Object Vall_ephemerons; /* Gemarke es niemals ever!!! */
1590
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3052 static Lisp_Object Vnew_all_ephemerons;
888
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3053 static Lisp_Object Vfinalize_list;
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3054
1590
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3055 void
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3056 init_marking_ephemerons(void)
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3057 {
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3058 Vnew_all_ephemerons = Qnil;
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3059 }
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3060
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3061 /* Move all live ephemerons with live keys over to
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3062 * Vnew_all_ephemerons, marking the values and finalizers along the
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3063 * way. */
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3064
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3065 int
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3066 continue_marking_ephemerons(void)
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3067 {
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3068 Lisp_Object rest = Vall_ephemerons, next, prev = Qnil;
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3069 int did_mark = 0;
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3070
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3071 while (!NILP (rest))
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3072 {
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3073 next = XEPHEMERON_NEXT (rest);
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3074
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3075 if (marked_p (rest))
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3076 {
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3077 MARK_CONS (XCONS (XEPHEMERON (rest)->cons_chain));
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3078 if (marked_p (XEPHEMERON (rest)->key))
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3079 {
1598
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3080 #ifdef USE_KKCC
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3081 kkcc_gc_stack_push_lisp_object
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3082 (XCAR (XEPHEMERON (rest)->cons_chain));
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3083 #else /* NOT USE_KKCC */
1590
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3084 mark_object (XCAR (XEPHEMERON (rest)->cons_chain));
1598
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3085 #endif /* NOT USE_KKCC */
1590
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3086 did_mark = 1;
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3087 XSET_EPHEMERON_NEXT (rest, Vnew_all_ephemerons);
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3088 Vnew_all_ephemerons = rest;
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3089 if (NILP (prev))
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3090 Vall_ephemerons = next;
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3091 else
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3092 XSET_EPHEMERON_NEXT (prev, next);
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3093 }
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3094 else
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3095 prev = rest;
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3096 }
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3097 else
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3098 prev = rest;
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3099
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3100 rest = next;
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3101 }
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3102
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3103 return did_mark;
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3104 }
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3105
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3106 /* At this point, everything that's in Vall_ephemerons is dead.
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3107 * Well, almost: we still need to run the finalizers, so we need to
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3108 * resurrect them.
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3109 */
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3110
888
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3111 int
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3112 finish_marking_ephemerons(void)
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3113 {
1590
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3114 Lisp_Object rest = Vall_ephemerons, next, prev = Qnil;
888
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3115 int did_mark = 0;
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3116
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3117 while (! NILP (rest))
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3118 {
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3119 next = XEPHEMERON_NEXT (rest);
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3120
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3121 if (marked_p (rest))
1590
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3122 /* The ephemeron itself is live, but its key is garbage */
888
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3123 {
1590
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3124 /* tombstone */
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3125 XSET_EPHEMERON_VALUE (rest, Qnil);
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3126
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3127 if (! NILP (XEPHEMERON_FINALIZER (rest)))
888
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3128 {
1590
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3129 MARK_CONS (XCONS (XEPHEMERON (rest)->cons_chain));
1598
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3130 #ifdef USE_KKCC
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3131 kkcc_gc_stack_push_lisp_object
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3132 (XCAR (XEPHEMERON (rest)->cons_chain));
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3133 #else /* NOT USE_KKCC */
1590
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3134 mark_object (XCAR (XEPHEMERON (rest)->cons_chain));
1598
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3135 #endif /* NOT USE_KKCC */
1590
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3136
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3137 /* Register the finalizer */
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3138 XSET_EPHEMERON_NEXT (rest, Vfinalize_list);
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3139 Vfinalize_list = XEPHEMERON (rest)->cons_chain;
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3140 did_mark = 1;
888
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3141 }
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3142
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3143 /* Remove it from the list. */
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3144 if (NILP (prev))
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3145 Vall_ephemerons = next;
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3146 else
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3147 XSET_EPHEMERON_NEXT (prev, next);
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3148 }
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3149 else
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3150 prev = rest;
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3151
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3152 rest = next;
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3153 }
1590
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3154
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3155 return did_mark;
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3156 }
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3157
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3158 void
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3159 prune_ephemerons(void)
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3160 {
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3161 Vall_ephemerons = Vnew_all_ephemerons;
888
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3162 }
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3163
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3164 Lisp_Object
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3165 zap_finalize_list(void)
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3166 {
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3167 Lisp_Object finalizers = Vfinalize_list;
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3168
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3169 Vfinalize_list = Qnil;
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3170
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3171 return finalizers;
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3172 }
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3173
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3174 static Lisp_Object
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3175 mark_ephemeron (Lisp_Object obj)
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3176 {
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3177 return Qnil;
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3178 }
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3179
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3180 static void
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3181 print_ephemeron (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3182 {
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3183 if (print_readably)
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3184 printing_unreadable_object ("#<ephemeron>");
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3185 write_fmt_string (printcharfun, "#<ephemeron>");
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3186 }
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3187
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3188 static int
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3189 ephemeron_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3190 {
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3191 return
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3192 internal_equal (XEPHEMERON_REF (obj1), XEPHEMERON_REF(obj2), depth + 1);
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3193 }
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3194
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3195 static Hashcode
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3196 ephemeron_hash(Lisp_Object obj, int depth)
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3197 {
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3198 return internal_hash (XEPHEMERON_REF (obj), depth + 1);
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3199 }
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3200
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3201 Lisp_Object
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3202 make_ephemeron(Lisp_Object key, Lisp_Object value, Lisp_Object finalizer)
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3203 {
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3204 Lisp_Object result, temp = Qnil;
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3205 struct gcpro gcpro1, gcpro2;
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3206
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3207 struct ephemeron *eph =
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3208 alloc_lcrecord_type (struct ephemeron, &lrecord_ephemeron);
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3209
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3210 eph->key = Qnil;
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3211 eph->cons_chain = Qnil;
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3212 eph->value = Qnil;
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3213
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3214 result = wrap_ephemeron(eph);
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3215 GCPRO2 (result, temp);
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3216
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3217 eph->key = key;
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3218 temp = Fcons(value, finalizer);
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3219 eph->cons_chain = Fcons(temp, Vall_ephemerons);
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3220 eph->value = value;
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3221
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3222 Vall_ephemerons = result;
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3223
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3224 UNGCPRO;
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3225 return result;
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3226 }
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3227
1598
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3228 /* Ephemerons are special cases in the KKCC mark algorithm, so nothing
ac1be85b4a5f [xemacs-hg @ 2003-07-31 13:32:24 by crestani]
crestani
parents: 1590
diff changeset
3229 is marked here. */
1204
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1104
diff changeset
3230 static const struct memory_description ephemeron_description[] = {
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1104
diff changeset
3231 { XD_LISP_OBJECT, offsetof(struct ephemeron, key),
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1104
diff changeset
3232 0, 0, XD_FLAG_NO_KKCC },
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1104
diff changeset
3233 { XD_LISP_OBJECT, offsetof(struct ephemeron, cons_chain),
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1104
diff changeset
3234 0, 0, XD_FLAG_NO_KKCC },
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1104
diff changeset
3235 { XD_LISP_OBJECT, offsetof(struct ephemeron, value),
e22b0213b713 [xemacs-hg @ 2003-01-12 11:07:58 by michaels]
michaels
parents: 1104
diff changeset
3236 0, 0, XD_FLAG_NO_KKCC },
888
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3237 { XD_END }
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3238 };
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3239
934
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 888
diff changeset
3240 DEFINE_LRECORD_IMPLEMENTATION ("ephemeron", ephemeron,
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 888
diff changeset
3241 0, /*dumpable-flag*/
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 888
diff changeset
3242 mark_ephemeron, print_ephemeron,
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 888
diff changeset
3243 0, ephemeron_equal, ephemeron_hash,
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 888
diff changeset
3244 ephemeron_description,
c925bacdda60 [xemacs-hg @ 2002-07-29 09:21:12 by michaels]
michaels
parents: 888
diff changeset
3245 struct ephemeron);
888
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3246
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3247 DEFUN ("make-ephemeron", Fmake_ephemeron, 2, 3, 0, /*
1590
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3248 Return a new ephemeron with key KEY, value VALUE, and finalizer FINALIZER.
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3249 The ephemeron is a reference to VALUE which may be extracted with
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3250 `ephemeron-ref'. VALUE is only reachable through the ephemeron as
888
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3251 long as KEY is reachable; the ephemeron does not contribute to the
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3252 reachability of KEY. When KEY becomes unreachable while the ephemeron
1590
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3253 itself is still reachable, VALUE is queued for finalization: FINALIZER
03009473262a [xemacs-hg @ 2003-07-26 14:00:27 by michaels]
michaels
parents: 1551
diff changeset
3254 will possibly be called on VALUE some time in the future. Moreover,
888
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3255 future calls to `ephemeron-ref' will return NIL.
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3256 */
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3257 (key, value, finalizer))
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3258 {
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3259 return make_ephemeron(key, value, finalizer);
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3260 }
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3261
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3262 DEFUN ("ephemeron-ref", Fephemeron_ref, 1, 1, 0, /*
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3263 Return the contents of ephemeron EPHEMERON.
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3264 If the contents have been GCed, return NIL.
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3265 */
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3266 (eph))
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3267 {
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3268 return XEPHEMERON_REF (eph);
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3269 }
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3270
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3271 DEFUN ("ephemeron-p", Fephemeronp, 1, 1, 0, /*
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3272 Return non-nil if OBJECT is an ephemeron.
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3273 */
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3274 (object))
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3275 {
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3276 return EPHEMERONP (object) ? Qt : Qnil;
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3277 }
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3278
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3279 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3280 /* initialization */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3281 /************************************************************************/
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3282
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3283 static SIGTYPE
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3284 arith_error (int signo)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3285 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3286 EMACS_REESTABLISH_SIGNAL (signo, arith_error);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3287 EMACS_UNBLOCK_SIGNAL (signo);
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 458
diff changeset
3288 signal_error (Qarith_error, 0, Qunbound);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3289 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3290
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3291 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3292 init_data_very_early (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3293 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3294 /* Don't do this if just dumping out.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3295 We don't want to call `signal' in this case
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3296 so that we don't have trouble with dumping
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3297 signal-delivering routines in an inconsistent state. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3298 if (!initialized)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3299 return;
613
023b83f4e54b [xemacs-hg @ 2001-06-10 10:42:16 by ben]
ben
parents: 603
diff changeset
3300 EMACS_SIGNAL (SIGFPE, arith_error);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3301 #ifdef uts
613
023b83f4e54b [xemacs-hg @ 2001-06-10 10:42:16 by ben]
ben
parents: 603
diff changeset
3302 EMACS_SIGNAL (SIGEMT, arith_error);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3303 #endif /* uts */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3304 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3305
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3306 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3307 init_errors_once_early (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3308 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3309 DEFSYMBOL (Qerror_conditions);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3310 DEFSYMBOL (Qerror_message);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3311
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3312 /* We declare the errors here because some other deferrors depend
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3313 on some of the errors below. */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3314
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3315 /* ERROR is used as a signaler for random errors for which nothing
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3316 else is right */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3317
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3318 DEFERROR (Qerror, "error", Qnil);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3319 DEFERROR_STANDARD (Qquit, Qnil);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3320
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 458
diff changeset
3321 DEFERROR_STANDARD (Qinvalid_argument, Qerror);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 458
diff changeset
3322
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 458
diff changeset
3323 DEFERROR_STANDARD (Qsyntax_error, Qinvalid_argument);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3324 DEFERROR_STANDARD (Qinvalid_read_syntax, Qsyntax_error);
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 458
diff changeset
3325 DEFERROR_STANDARD (Qstructure_formation_error, Qsyntax_error);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 458
diff changeset
3326 DEFERROR_STANDARD (Qlist_formation_error, Qstructure_formation_error);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3327 DEFERROR_STANDARD (Qmalformed_list, Qlist_formation_error);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3328 DEFERROR_STANDARD (Qmalformed_property_list, Qmalformed_list);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3329 DEFERROR_STANDARD (Qcircular_list, Qlist_formation_error);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3330 DEFERROR_STANDARD (Qcircular_property_list, Qcircular_list);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3331
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3332 DEFERROR_STANDARD (Qwrong_type_argument, Qinvalid_argument);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3333 DEFERROR_STANDARD (Qargs_out_of_range, Qinvalid_argument);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3334 DEFERROR_STANDARD (Qwrong_number_of_arguments, Qinvalid_argument);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3335 DEFERROR_STANDARD (Qinvalid_function, Qinvalid_argument);
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 458
diff changeset
3336 DEFERROR_STANDARD (Qinvalid_constant, Qinvalid_argument);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3337 DEFERROR (Qno_catch, "No catch for tag", Qinvalid_argument);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3338
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 458
diff changeset
3339 DEFERROR_STANDARD (Qinvalid_state, Qerror);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3340 DEFERROR (Qvoid_function, "Symbol's function definition is void",
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3341 Qinvalid_state);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3342 DEFERROR (Qcyclic_function_indirection,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3343 "Symbol's chain of function indirections contains a loop",
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3344 Qinvalid_state);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3345 DEFERROR (Qvoid_variable, "Symbol's value as variable is void",
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3346 Qinvalid_state);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3347 DEFERROR (Qcyclic_variable_indirection,
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3348 "Symbol's chain of variable indirections contains a loop",
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3349 Qinvalid_state);
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 458
diff changeset
3350 DEFERROR_STANDARD (Qstack_overflow, Qinvalid_state);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 458
diff changeset
3351 DEFERROR_STANDARD (Qinternal_error, Qinvalid_state);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 458
diff changeset
3352 DEFERROR_STANDARD (Qout_of_memory, Qinvalid_state);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3353
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 458
diff changeset
3354 DEFERROR_STANDARD (Qinvalid_operation, Qerror);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 458
diff changeset
3355 DEFERROR_STANDARD (Qinvalid_change, Qinvalid_operation);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3356 DEFERROR (Qsetting_constant, "Attempt to set a constant symbol",
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3357 Qinvalid_change);
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 458
diff changeset
3358 DEFERROR_STANDARD (Qprinting_unreadable_object, Qinvalid_operation);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 458
diff changeset
3359 DEFERROR (Qunimplemented, "Feature not yet implemented", Qinvalid_operation);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3360
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 458
diff changeset
3361 DEFERROR_STANDARD (Qediting_error, Qinvalid_operation);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3362 DEFERROR_STANDARD (Qbeginning_of_buffer, Qediting_error);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3363 DEFERROR_STANDARD (Qend_of_buffer, Qediting_error);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3364 DEFERROR (Qbuffer_read_only, "Buffer is read-only", Qediting_error);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3365
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3366 DEFERROR (Qio_error, "IO Error", Qinvalid_operation);
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 458
diff changeset
3367 DEFERROR_STANDARD (Qfile_error, Qio_error);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 458
diff changeset
3368 DEFERROR (Qend_of_file, "End of file or stream", Qfile_error);
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 458
diff changeset
3369 DEFERROR_STANDARD (Qconversion_error, Qio_error);
580
55e998c311f5 [xemacs-hg @ 2001-05-26 12:24:50 by ben]
ben
parents: 563
diff changeset
3370 DEFERROR_STANDARD (Qtext_conversion_error, Qconversion_error);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3371
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3372 DEFERROR (Qarith_error, "Arithmetic error", Qinvalid_operation);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3373 DEFERROR (Qrange_error, "Arithmetic range error", Qarith_error);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3374 DEFERROR (Qdomain_error, "Arithmetic domain error", Qarith_error);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3375 DEFERROR (Qsingularity_error, "Arithmetic singularity error", Qdomain_error);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3376 DEFERROR (Qoverflow_error, "Arithmetic overflow error", Qdomain_error);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3377 DEFERROR (Qunderflow_error, "Arithmetic underflow error", Qdomain_error);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3378 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3379
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3380 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3381 syms_of_data (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3382 {
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3383 INIT_LRECORD_IMPLEMENTATION (weak_list);
888
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3384 INIT_LRECORD_IMPLEMENTATION (ephemeron);
858
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
3385 INIT_LRECORD_IMPLEMENTATION (weak_box);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3386
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3387 DEFSYMBOL (Qquote);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3388 DEFSYMBOL (Qlambda);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3389 DEFSYMBOL (Qlistp);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3390 DEFSYMBOL (Qtrue_list_p);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3391 DEFSYMBOL (Qconsp);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3392 DEFSYMBOL (Qsubrp);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3393 DEFSYMBOL (Qsymbolp);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3394 DEFSYMBOL (Qintegerp);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3395 DEFSYMBOL (Qcharacterp);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3396 DEFSYMBOL (Qnatnump);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
3397 DEFSYMBOL (Qnonnegativep);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3398 DEFSYMBOL (Qstringp);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3399 DEFSYMBOL (Qarrayp);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3400 DEFSYMBOL (Qsequencep);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3401 DEFSYMBOL (Qbufferp);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3402 DEFSYMBOL (Qbitp);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3403 DEFSYMBOL_MULTIWORD_PREDICATE (Qbit_vectorp);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3404 DEFSYMBOL (Qvectorp);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3405 DEFSYMBOL (Qchar_or_string_p);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3406 DEFSYMBOL (Qmarkerp);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3407 DEFSYMBOL (Qinteger_or_marker_p);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3408 DEFSYMBOL (Qinteger_or_char_p);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3409 DEFSYMBOL (Qinteger_char_or_marker_p);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3410 DEFSYMBOL (Qnumberp);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3411 DEFSYMBOL (Qnumber_char_or_marker_p);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3412 DEFSYMBOL (Qcdr);
563
183866b06e0b [xemacs-hg @ 2001-05-24 07:50:48 by ben]
ben
parents: 458
diff changeset
3413 DEFSYMBOL (Qerror_lacks_explanatory_string);
442
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3414 DEFSYMBOL_MULTIWORD_PREDICATE (Qweak_listp);
abe6d1db359e Import from CVS: tag r21-2-36
cvs
parents: 440
diff changeset
3415 DEFSYMBOL (Qfloatp);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3416
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3417 DEFSUBR (Fwrong_type_argument);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3418
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
3419 #ifdef HAVE_RATIO
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
3420 DEFSUBR (Fdiv);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
3421 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3422 DEFSUBR (Feq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3423 DEFSUBR (Fold_eq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3424 DEFSUBR (Fnull);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3425 Ffset (intern ("not"), intern ("null"));
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3426 DEFSUBR (Flistp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3427 DEFSUBR (Fnlistp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3428 DEFSUBR (Ftrue_list_p);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3429 DEFSUBR (Fconsp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3430 DEFSUBR (Fatom);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3431 DEFSUBR (Fchar_or_string_p);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3432 DEFSUBR (Fcharacterp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3433 DEFSUBR (Fchar_int_p);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3434 DEFSUBR (Fchar_to_int);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3435 DEFSUBR (Fint_to_char);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3436 DEFSUBR (Fchar_or_char_int_p);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
3437 #ifdef HAVE_BIGNUM
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
3438 DEFSUBR (Ffixnump);
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
3439 #else
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3440 DEFSUBR (Fintegerp);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
3441 #endif
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3442 DEFSUBR (Finteger_or_marker_p);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3443 DEFSUBR (Finteger_or_char_p);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3444 DEFSUBR (Finteger_char_or_marker_p);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3445 DEFSUBR (Fnumberp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3446 DEFSUBR (Fnumber_or_marker_p);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3447 DEFSUBR (Fnumber_char_or_marker_p);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3448 DEFSUBR (Ffloatp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3449 DEFSUBR (Fnatnump);
1983
9c872f33ecbe [xemacs-hg @ 2004-04-05 22:49:31 by james]
james
parents: 1598
diff changeset
3450 DEFSUBR (Fnonnegativep);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3451 DEFSUBR (Fsymbolp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3452 DEFSUBR (Fkeywordp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3453 DEFSUBR (Fstringp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3454 DEFSUBR (Fvectorp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3455 DEFSUBR (Fbitp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3456 DEFSUBR (Fbit_vector_p);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3457 DEFSUBR (Farrayp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3458 DEFSUBR (Fsequencep);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3459 DEFSUBR (Fmarkerp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3460 DEFSUBR (Fsubrp);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3461 DEFSUBR (Fsubr_min_args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3462 DEFSUBR (Fsubr_max_args);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3463 DEFSUBR (Fsubr_interactive);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3464 DEFSUBR (Ftype_of);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3465 DEFSUBR (Fcar);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3466 DEFSUBR (Fcdr);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3467 DEFSUBR (Fcar_safe);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3468 DEFSUBR (Fcdr_safe);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3469 DEFSUBR (Fsetcar);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3470 DEFSUBR (Fsetcdr);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3471 DEFSUBR (Findirect_function);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3472 DEFSUBR (Faref);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3473 DEFSUBR (Faset);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3474
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3475 DEFSUBR (Fnumber_to_string);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3476 DEFSUBR (Fstring_to_number);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3477 DEFSUBR (Feqlsign);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3478 DEFSUBR (Flss);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3479 DEFSUBR (Fgtr);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3480 DEFSUBR (Fleq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3481 DEFSUBR (Fgeq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3482 DEFSUBR (Fneq);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3483 DEFSUBR (Fzerop);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3484 DEFSUBR (Fplus);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3485 DEFSUBR (Fminus);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3486 DEFSUBR (Ftimes);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3487 DEFSUBR (Fquo);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3488 DEFSUBR (Frem);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3489 DEFSUBR (Fmod);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3490 DEFSUBR (Fmax);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3491 DEFSUBR (Fmin);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3492 DEFSUBR (Flogand);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3493 DEFSUBR (Flogior);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3494 DEFSUBR (Flogxor);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3495 DEFSUBR (Flsh);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3496 DEFSUBR (Fash);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3497 DEFSUBR (Fadd1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3498 DEFSUBR (Fsub1);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3499 DEFSUBR (Flognot);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3500
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3501 DEFSUBR (Fweak_list_p);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3502 DEFSUBR (Fmake_weak_list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3503 DEFSUBR (Fweak_list_type);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3504 DEFSUBR (Fweak_list_list);
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3505 DEFSUBR (Fset_weak_list_list);
858
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
3506
888
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3507 DEFSUBR (Fmake_ephemeron);
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3508 DEFSUBR (Fephemeron_ref);
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3509 DEFSUBR (Fephemeronp);
858
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
3510 DEFSUBR (Fmake_weak_box);
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
3511 DEFSUBR (Fweak_box_ref);
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
3512 DEFSUBR (Fweak_boxp);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3513 }
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3514
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3515 void
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3516 vars_of_data (void)
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3517 {
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3518 /* This must not be staticpro'd */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3519 Vall_weak_lists = Qnil;
452
3d3049ae1304 Import from CVS: tag r21-2-41
cvs
parents: 444
diff changeset
3520 dump_add_weak_object_chain (&Vall_weak_lists);
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3521
888
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3522 Vall_ephemerons = Qnil;
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3523 dump_add_weak_object_chain (&Vall_ephemerons);
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3524
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3525 Vfinalize_list = Qnil;
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3526 staticpro (&Vfinalize_list);
201c016cfc12 [xemacs-hg @ 2002-06-28 14:24:07 by michaels]
michaels
parents: 867
diff changeset
3527
858
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
3528 Vall_weak_boxes = Qnil;
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
3529 dump_add_weak_object_chain (&Vall_weak_boxes);
2c12fe2da451 [xemacs-hg @ 2002-05-31 09:38:45 by michaels]
michaels
parents: 826
diff changeset
3530
428
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3531 #ifdef DEBUG_XEMACS
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3532 DEFVAR_BOOL ("debug-issue-ebola-notices", &debug_issue_ebola_notices /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3533 If non-zero, note when your code may be suffering from char-int confoundance.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3534 That is to say, if XEmacs encounters a usage of `eq', `memq', `equal',
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3535 etc. where an int and a char with the same value are being compared,
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3536 it will issue a notice on stderr to this effect, along with a backtrace.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3537 In such situations, the result would be different in XEmacs 19 versus
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3538 XEmacs 20, and you probably don't want this.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3539
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3540 Note that in order to see these notices, you have to byte compile your
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3541 code under XEmacs 20 -- any code byte-compiled under XEmacs 19 will
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3542 have its chars and ints all confounded in the byte code, making it
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3543 impossible to accurately determine Ebola infection.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3544 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3545
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3546 debug_issue_ebola_notices = 0;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3547
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3548 DEFVAR_INT ("debug-ebola-backtrace-length",
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3549 &debug_ebola_backtrace_length /*
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3550 Length (in stack frames) of short backtrace printed out in Ebola notices.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3551 See `debug-issue-ebola-notices'.
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3552 */ );
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3553 debug_ebola_backtrace_length = 32;
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3554
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3555 #endif /* DEBUG_XEMACS */
3ecd8885ac67 Import from CVS: tag r21-2-22
cvs
parents:
diff changeset
3556 }