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