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