Mercurial > hg > xemacs-beta
annotate src/data.c @ 5793:cf0201de66df
Help buffer behaviour synced with GNU
lisp/ChangeLog:
2014-04-19 Mats Lidell <matsl@xemacs.org>
* help.el: Sync from GNU - Link to customize if applicable and
display version info. Other changes: Remove use of button-2.
return and button-1 use activate-function. Move between
activate-function-extents with tab.
tests/ChangeLog:
2014-04-19 Mats Lidell <matsl@xemacs.org>
* automated/keymap-tests.el: Use
help-activate-function-or-scroll-up.
| author | Mats Lidell <mats.lidell@cag.se> |
|---|---|
| date | Fri, 25 Apr 2014 23:38:16 +0200 |
| parents | ffc0c5a66ab1 |
| children | 750fab17b299 574f0cded429 |
| 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, /* | |
|
5752
70a3f4ff8da8
Improve coding style, variable names, data.c, sequence.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5736
diff
changeset
|
575 Return the car of LIST. If LIST is nil, return nil. |
| 3343 | 576 The car of a list or a dotted pair is its first element. |
| 577 | |
|
5752
70a3f4ff8da8
Improve coding style, variable names, data.c, sequence.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5736
diff
changeset
|
578 Error if LIST is not nil and not a cons cell. See also `car-safe'. |
| 428 | 579 */ |
|
5752
70a3f4ff8da8
Improve coding style, variable names, data.c, sequence.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5736
diff
changeset
|
580 (list)) |
| 428 | 581 { |
| 582 while (1) | |
| 583 { | |
|
5752
70a3f4ff8da8
Improve coding style, variable names, data.c, sequence.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5736
diff
changeset
|
584 if (CONSP (list)) |
|
70a3f4ff8da8
Improve coding style, variable names, data.c, sequence.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5736
diff
changeset
|
585 return XCAR (list); |
|
70a3f4ff8da8
Improve coding style, variable names, data.c, sequence.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5736
diff
changeset
|
586 else if (NILP (list)) |
| 428 | 587 return Qnil; |
| 588 else | |
|
5752
70a3f4ff8da8
Improve coding style, variable names, data.c, sequence.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5736
diff
changeset
|
589 list = wrong_type_argument (Qlistp, list); |
| 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, /* | |
|
5752
70a3f4ff8da8
Improve coding style, variable names, data.c, sequence.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5736
diff
changeset
|
602 Return the cdr of LIST. If LIST is nil, return nil. |
| 3343 | 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 */ | |
|
5752
70a3f4ff8da8
Improve coding style, variable names, data.c, sequence.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5736
diff
changeset
|
608 (list)) |
| 428 | 609 { |
| 610 while (1) | |
| 611 { | |
|
5752
70a3f4ff8da8
Improve coding style, variable names, data.c, sequence.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5736
diff
changeset
|
612 if (CONSP (list)) |
|
70a3f4ff8da8
Improve coding style, variable names, data.c, sequence.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5736
diff
changeset
|
613 return XCDR (list); |
|
70a3f4ff8da8
Improve coding style, variable names, data.c, sequence.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5736
diff
changeset
|
614 else if (NILP (list)) |
| 428 | 615 return Qnil; |
| 616 else | |
|
5752
70a3f4ff8da8
Improve coding style, variable names, data.c, sequence.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5736
diff
changeset
|
617 list = wrong_type_argument (Qlistp, list); |
| 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) \ | |
|
5769
ffc0c5a66ab1
Be lazy converting markers to integers, bytecode_{arithcompare,arithop}().
Aidan Kehoe <kehoea@parhasard.net>
parents:
5768
diff
changeset
|
902 case LAZY_BIGNUM_T: \ |
| 1983 | 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) \ | |
|
5769
ffc0c5a66ab1
Be lazy converting markers to integers, bytecode_{arithcompare,arithop}().
Aidan Kehoe <kehoea@parhasard.net>
parents:
5768
diff
changeset
|
912 case LAZY_RATIO_T: \ |
| 1983 | 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) \ | |
|
5769
ffc0c5a66ab1
Be lazy converting markers to integers, bytecode_{arithcompare,arithop}().
Aidan Kehoe <kehoea@parhasard.net>
parents:
5768
diff
changeset
|
922 case LAZY_BIGFLOAT_T: \ |
| 1983 | 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]; \ | |
|
5769
ffc0c5a66ab1
Be lazy converting markers to integers, bytecode_{arithcompare,arithop}().
Aidan Kehoe <kehoea@parhasard.net>
parents:
5768
diff
changeset
|
939 switch (promote_args_lazy (&obj1, &obj2)) \ |
| 1983 | 940 { \ |
|
5769
ffc0c5a66ab1
Be lazy converting markers to integers, bytecode_{arithcompare,arithop}().
Aidan Kehoe <kehoea@parhasard.net>
parents:
5768
diff
changeset
|
941 case LAZY_FIXNUM_T: \ |
|
ffc0c5a66ab1
Be lazy converting markers to integers, bytecode_{arithcompare,arithop}().
Aidan Kehoe <kehoea@parhasard.net>
parents:
5768
diff
changeset
|
942 if (!(XREALFIXNUM (obj1) c_op XREALFIXNUM (obj2))) \ |
| 1983 | 943 return Qnil; \ |
| 944 break; \ | |
| 945 BIGNUM_CASE (op) \ | |
| 946 RATIO_CASE (op) \ | |
|
5769
ffc0c5a66ab1
Be lazy converting markers to integers, bytecode_{arithcompare,arithop}().
Aidan Kehoe <kehoea@parhasard.net>
parents:
5768
diff
changeset
|
947 case LAZY_FLOAT_T: \ |
| 1983 | 948 if (!(XFLOAT_DATA (obj1) c_op XFLOAT_DATA (obj2))) \ |
| 949 return Qnil; \ | |
| 950 break; \ | |
| 951 BIGFLOAT_CASE (op) \ | |
|
5769
ffc0c5a66ab1
Be lazy converting markers to integers, bytecode_{arithcompare,arithop}().
Aidan Kehoe <kehoea@parhasard.net>
parents:
5768
diff
changeset
|
952 case LAZY_MARKER_T: \ |
|
ffc0c5a66ab1
Be lazy converting markers to integers, bytecode_{arithcompare,arithop}().
Aidan Kehoe <kehoea@parhasard.net>
parents:
5768
diff
changeset
|
953 if (!(byte_marker_position (obj1) c_op \ |
|
ffc0c5a66ab1
Be lazy converting markers to integers, bytecode_{arithcompare,arithop}().
Aidan Kehoe <kehoea@parhasard.net>
parents:
5768
diff
changeset
|
954 byte_marker_position (obj2))) \ |
|
ffc0c5a66ab1
Be lazy converting markers to integers, bytecode_{arithcompare,arithop}().
Aidan Kehoe <kehoea@parhasard.net>
parents:
5768
diff
changeset
|
955 return Qnil; \ |
|
ffc0c5a66ab1
Be lazy converting markers to integers, bytecode_{arithcompare,arithop}().
Aidan Kehoe <kehoea@parhasard.net>
parents:
5768
diff
changeset
|
956 break; \ |
| 1983 | 957 } \ |
| 958 } \ | |
| 959 return Qt; \ | |
| 960 } | |
| 961 #else /* !WITH_NUMBER_TYPES */ | |
|
5769
ffc0c5a66ab1
Be lazy converting markers to integers, bytecode_{arithcompare,arithop}().
Aidan Kehoe <kehoea@parhasard.net>
parents:
5768
diff
changeset
|
962 /* We don't convert markers lazily here, although we could. It's more |
|
ffc0c5a66ab1
Be lazy converting markers to integers, bytecode_{arithcompare,arithop}().
Aidan Kehoe <kehoea@parhasard.net>
parents:
5768
diff
changeset
|
963 important that we do this lazily in bytecode, which is the case; see |
|
ffc0c5a66ab1
Be lazy converting markers to integers, bytecode_{arithcompare,arithop}().
Aidan Kehoe <kehoea@parhasard.net>
parents:
5768
diff
changeset
|
964 bytecode_arithcompare(). |
|
ffc0c5a66ab1
Be lazy converting markers to integers, bytecode_{arithcompare,arithop}().
Aidan Kehoe <kehoea@parhasard.net>
parents:
5768
diff
changeset
|
965 */ |
| 1983 | 966 #define ARITHCOMPARE_MANY(c_op,op) \ |
| 428 | 967 { \ |
| 968 int_or_double iod1, iod2, *p = &iod1, *q = &iod2; \ | |
| 969 Lisp_Object *args_end = args + nargs; \ | |
| 970 \ | |
| 971 number_char_or_marker_to_int_or_double (*args++, p); \ | |
| 972 \ | |
| 973 while (args < args_end) \ | |
| 974 { \ | |
| 975 number_char_or_marker_to_int_or_double (*args++, q); \ | |
| 976 \ | |
| 977 if (!((p->int_p && q->int_p) ? \ | |
| 1983 | 978 (p->c.ival c_op q->c.ival) : \ |
| 979 ((p->int_p ? (double) p->c.ival : p->c.dval) c_op \ | |
| 428 | 980 (q->int_p ? (double) q->c.ival : q->c.dval)))) \ |
| 981 return Qnil; \ | |
| 982 \ | |
| 983 { /* swap */ int_or_double *r = p; p = q; q = r; } \ | |
| 984 } \ | |
| 985 return Qt; \ | |
| 986 } | |
| 1983 | 987 #endif /* WITH_NUMBER_TYPES */ |
| 428 | 988 |
| 989 DEFUN ("=", Feqlsign, 1, MANY, 0, /* | |
| 990 Return t if all the arguments are numerically equal. | |
| 991 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
|
992 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
993 arguments: (FIRST &rest ARGS) |
| 428 | 994 */ |
| 995 (int nargs, Lisp_Object *args)) | |
| 996 { | |
| 1983 | 997 ARITHCOMPARE_MANY (==, eql) |
| 428 | 998 } |
| 999 | |
| 1000 DEFUN ("<", Flss, 1, MANY, 0, /* | |
| 1001 Return t if the sequence of arguments is monotonically increasing. | |
| 3343 | 1002 |
| 1003 (That is, if there is a second argument, it must be numerically greater than | |
| 1004 the first. If there is a third, it must be numerically greater than the | |
| 1005 second, and so on.) At least one argument is required. | |
| 1006 | |
| 1007 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
|
1008 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1009 arguments: (FIRST &rest ARGS) |
| 428 | 1010 */ |
| 1011 (int nargs, Lisp_Object *args)) | |
| 1012 { | |
| 1983 | 1013 ARITHCOMPARE_MANY (<, lt) |
| 428 | 1014 } |
| 1015 | |
| 1016 DEFUN (">", Fgtr, 1, MANY, 0, /* | |
| 1017 Return t if the sequence of arguments is monotonically decreasing. | |
| 3343 | 1018 |
| 1019 (That is, if there is a second argument, it must be numerically less than | |
| 1020 the first. If there is a third, it must be numerically less than the | |
| 1021 second, and so forth.) At least one argument is required. | |
| 1022 | |
| 428 | 1023 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
|
1024 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1025 arguments: (FIRST &rest ARGS) |
| 428 | 1026 */ |
| 1027 (int nargs, Lisp_Object *args)) | |
| 1028 { | |
| 1983 | 1029 ARITHCOMPARE_MANY (>, gt) |
| 428 | 1030 } |
| 1031 | |
| 1032 DEFUN ("<=", Fleq, 1, MANY, 0, /* | |
| 1033 Return t if the sequence of arguments is monotonically nondecreasing. | |
| 1034 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
|
1035 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1036 arguments: (FIRST &rest ARGS) |
| 428 | 1037 */ |
| 1038 (int nargs, Lisp_Object *args)) | |
| 1039 { | |
| 1983 | 1040 ARITHCOMPARE_MANY (<=, le) |
| 428 | 1041 } |
| 1042 | |
| 1043 DEFUN (">=", Fgeq, 1, MANY, 0, /* | |
| 1044 Return t if the sequence of arguments is monotonically nonincreasing. | |
| 1045 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
|
1046 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1047 arguments: (FIRST &rest ARGS) |
| 428 | 1048 */ |
| 1049 (int nargs, Lisp_Object *args)) | |
| 1050 { | |
| 1983 | 1051 ARITHCOMPARE_MANY (>=, ge) |
| 428 | 1052 } |
| 1053 | |
| 1983 | 1054 /* Unlike all the other comparisons, this is an O(N*N) algorithm. But who |
| 1055 cares? Inspection of all elisp code distributed by xemacs.org shows that | |
| 1056 it is almost always called with 2 arguments, rarely with 3, and never with | |
| 1057 more than 3. The constant factors of algorithms with better asymptotic | |
| 1058 complexity are higher, which means that those algorithms will run SLOWER | |
| 1059 than this one in the common case. Optimize the common case! */ | |
| 428 | 1060 DEFUN ("/=", Fneq, 1, MANY, 0, /* |
| 1061 Return t if no two arguments are numerically equal. | |
| 1062 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
|
1063 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1064 arguments: (FIRST &rest ARGS) |
| 428 | 1065 */ |
| 1066 (int nargs, Lisp_Object *args)) | |
| 1067 { | |
| 1983 | 1068 #ifdef WITH_NUMBER_TYPES |
| 1069 REGISTER int i, j; | |
| 1070 Lisp_Object obj1, obj2; | |
| 1071 | |
| 1072 for (i = 0; i < nargs - 1; i++) | |
| 1073 { | |
| 1074 obj1 = args[i]; | |
| 1075 for (j = i + 1; j < nargs; j++) | |
| 1076 { | |
| 1077 obj2 = args[j]; | |
| 1078 switch (promote_args (&obj1, &obj2)) | |
| 1079 { | |
| 1080 case FIXNUM_T: | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
1081 if (XREALFIXNUM (obj1) == XREALFIXNUM (obj2)) |
| 1983 | 1082 return Qnil; |
| 1083 break; | |
| 1084 #ifdef HAVE_BIGNUM | |
| 1085 case BIGNUM_T: | |
| 1086 if (bignum_eql (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2))) | |
| 1087 return Qnil; | |
| 1088 break; | |
| 1089 #endif | |
| 1090 #ifdef HAVE_RATIO | |
| 1091 case RATIO_T: | |
| 1092 if (ratio_eql (XRATIO_DATA (obj1), XRATIO_DATA (obj2))) | |
| 1093 return Qnil; | |
| 1094 break; | |
| 1095 #endif | |
| 1096 case FLOAT_T: | |
| 1097 if (XFLOAT_DATA (obj1) == XFLOAT_DATA (obj2)) | |
| 1098 return Qnil; | |
| 1099 break; | |
| 1100 #ifdef HAVE_BIGFLOAT | |
| 1101 case BIGFLOAT_T: | |
| 1102 if (bigfloat_eql (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2))) | |
| 1103 return Qnil; | |
| 1104 break; | |
| 1105 #endif | |
| 1106 } | |
| 1107 } | |
| 1108 } | |
| 1109 return Qt; | |
| 1110 #else /* !WITH_NUMBER_TYPES */ | |
| 428 | 1111 Lisp_Object *args_end = args + nargs; |
| 1112 Lisp_Object *p, *q; | |
| 1113 | |
| 1114 /* Unlike all the other comparisons, this is an N*N algorithm. | |
| 1115 We could use a hash table for nargs > 50 to make this linear. */ | |
| 1116 for (p = args; p < args_end; p++) | |
| 1117 { | |
| 1118 int_or_double iod1, iod2; | |
| 1119 number_char_or_marker_to_int_or_double (*p, &iod1); | |
| 1120 | |
| 1121 for (q = p + 1; q < args_end; q++) | |
| 1122 { | |
| 1123 number_char_or_marker_to_int_or_double (*q, &iod2); | |
| 1124 | |
| 1125 if (!((iod1.int_p && iod2.int_p) ? | |
| 1126 (iod1.c.ival != iod2.c.ival) : | |
| 1127 ((iod1.int_p ? (double) iod1.c.ival : iod1.c.dval) != | |
| 1128 (iod2.int_p ? (double) iod2.c.ival : iod2.c.dval)))) | |
| 1129 return Qnil; | |
| 1130 } | |
| 1131 } | |
| 1132 return Qt; | |
| 1983 | 1133 #endif /* WITH_NUMBER_TYPES */ |
| 428 | 1134 } |
| 1135 | |
| 1136 DEFUN ("zerop", Fzerop, 1, 1, 0, /* | |
| 1137 Return t if NUMBER is zero. | |
| 1138 */ | |
| 1139 (number)) | |
| 1140 { | |
| 1141 retry: | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
1142 if (FIXNUMP (number)) |
| 428 | 1143 return EQ (number, Qzero) ? Qt : Qnil; |
| 1983 | 1144 #ifdef HAVE_BIGNUM |
| 1145 else if (BIGNUMP (number)) | |
| 1146 return bignum_sign (XBIGNUM_DATA (number)) == 0 ? Qt : Qnil; | |
| 1147 #endif | |
| 1148 #ifdef HAVE_RATIO | |
| 1149 else if (RATIOP (number)) | |
| 1150 return ratio_sign (XRATIO_DATA (number)) == 0 ? Qt : Qnil; | |
| 1151 #endif | |
| 428 | 1152 else if (FLOATP (number)) |
| 1153 return XFLOAT_DATA (number) == 0.0 ? Qt : Qnil; | |
| 1983 | 1154 #ifdef HAVE_BIGFLOAT |
| 1155 else if (BIGFLOATP (number)) | |
| 1156 return bigfloat_sign (XBIGFLOAT_DATA (number)) == 0 ? Qt : Qnil; | |
| 1157 #endif | |
| 428 | 1158 else |
| 1159 { | |
| 1160 number = wrong_type_argument (Qnumberp, number); | |
| 1161 goto retry; | |
| 1162 } | |
| 1163 } | |
| 1164 | |
| 1165 /* Convert between a 32-bit value and a cons of two 16-bit values. | |
| 1166 This is used to pass 32-bit integers to and from the user. | |
| 1167 Use time_to_lisp() and lisp_to_time() for time values. | |
| 1168 | |
| 1169 If you're thinking of using this to store a pointer into a Lisp Object | |
| 1170 for internal purposes (such as when calling record_unwind_protect()), | |
| 1171 try using make_opaque_ptr()/get_opaque_ptr() instead. */ | |
| 1172 Lisp_Object | |
| 1173 word_to_lisp (unsigned int item) | |
| 1174 { | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
1175 return Fcons (make_fixnum (item >> 16), make_fixnum (item & 0xffff)); |
| 428 | 1176 } |
| 1177 | |
| 1178 unsigned int | |
| 1179 lisp_to_word (Lisp_Object item) | |
| 1180 { | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
1181 if (FIXNUMP (item)) |
|
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
1182 return XFIXNUM (item); |
| 428 | 1183 else |
| 1184 { | |
| 1185 Lisp_Object top = Fcar (item); | |
| 1186 Lisp_Object bot = Fcdr (item); | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
1187 CHECK_FIXNUM (top); |
|
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
1188 CHECK_FIXNUM (bot); |
|
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
1189 return (XFIXNUM (top) << 16) | (XFIXNUM (bot) & 0xffff); |
| 428 | 1190 } |
| 1191 } | |
| 1192 | |
| 1193 | |
| 1194 DEFUN ("number-to-string", Fnumber_to_string, 1, 1, 0, /* | |
| 444 | 1195 Convert NUMBER to a string by printing it in decimal. |
| 428 | 1196 Uses a minus sign if negative. |
| 444 | 1197 NUMBER may be an integer or a floating point number. |
| 1983 | 1198 If supported, it may also be a ratio. |
| 428 | 1199 */ |
| 444 | 1200 (number)) |
| 428 | 1201 { |
| 1983 | 1202 CHECK_NUMBER (number); |
| 428 | 1203 |
| 444 | 1204 if (FLOATP (number)) |
| 428 | 1205 { |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1206 Ascbyte pigbuf[350]; /* see comments in float_to_string */ |
| 428 | 1207 |
| 444 | 1208 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
|
1209 return build_ascstring (pigbuf); |
| 428 | 1210 } |
| 1983 | 1211 #ifdef HAVE_BIGNUM |
| 1212 if (BIGNUMP (number)) | |
| 1213 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1214 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
|
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_RATIO | |
| 1221 if (RATIOP (number)) | |
| 1222 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1223 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
|
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 | |
| 1229 #ifdef HAVE_BIGFLOAT | |
| 1230 if (BIGFLOATP (number)) | |
| 1231 { | |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1232 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
|
1233 Lisp_Object retval = build_ascstring (str); |
|
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
1234 xfree (str); |
| 1983 | 1235 return retval; |
| 1236 } | |
| 1237 #endif | |
| 428 | 1238 |
| 603 | 1239 { |
|
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4846
diff
changeset
|
1240 Ascbyte buffer[DECIMAL_PRINT_SIZE (long)]; |
| 603 | 1241 |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
1242 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
|
1243 return build_ascstring (buffer); |
| 603 | 1244 } |
| 428 | 1245 } |
| 1246 | |
| 2001 | 1247 #ifndef HAVE_BIGNUM |
| 428 | 1248 static int |
| 1249 digit_to_number (int character, int base) | |
| 1250 { | |
| 1251 /* Assumes ASCII */ | |
| 1252 int digit = ((character >= '0' && character <= '9') ? character - '0' : | |
| 1253 (character >= 'a' && character <= 'z') ? character - 'a' + 10 : | |
| 1254 (character >= 'A' && character <= 'Z') ? character - 'A' + 10 : | |
| 1255 -1); | |
| 1256 | |
| 1257 return digit >= base ? -1 : digit; | |
| 1258 } | |
| 2001 | 1259 #endif |
| 428 | 1260 |
| 1261 DEFUN ("string-to-number", Fstring_to_number, 1, 2, 0, /* | |
| 444 | 1262 Convert STRING to a number by parsing it as a number in base BASE. |
| 428 | 1263 This parses both integers and floating point numbers. |
| 1983 | 1264 If they are supported, it also reads ratios. |
| 428 | 1265 It ignores leading spaces and tabs. |
| 1266 | |
| 444 | 1267 If BASE is nil or omitted, base 10 is used. |
| 1268 BASE must be an integer between 2 and 16 (inclusive). | |
| 428 | 1269 Floating point numbers always use base 10. |
| 1270 */ | |
| 1271 (string, base)) | |
| 1272 { | |
| 1995 | 1273 Ibyte *p; |
| 428 | 1274 int b; |
| 1275 | |
| 1276 CHECK_STRING (string); | |
| 1277 | |
| 1278 if (NILP (base)) | |
| 1279 b = 10; | |
| 1280 else | |
| 1281 { | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
1282 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
|
1283 b = XFIXNUM (base); |
| 428 | 1284 } |
| 1285 | |
| 1995 | 1286 p = XSTRING_DATA (string); |
| 428 | 1287 |
| 1288 /* Skip any whitespace at the front of the number. Some versions of | |
| 1289 atoi do this anyway, so we might as well make Emacs lisp consistent. */ | |
| 1290 while (*p == ' ' || *p == '\t') | |
| 1291 p++; | |
| 1292 | |
| 1995 | 1293 if (isfloat_string ((const char *) p) && b == 10) |
| 1983 | 1294 { |
| 1295 #ifdef HAVE_BIGFLOAT | |
| 1296 if (ZEROP (Vdefault_float_precision)) | |
| 1297 #endif | |
| 1995 | 1298 return make_float (atof ((const char *) p)); |
| 1983 | 1299 #ifdef HAVE_BIGFLOAT |
| 1300 else | |
| 1301 { | |
| 2013 | 1302 /* The GMP version of bigfloat_set_string (mpf_set_str) has the |
| 1303 following limitation: if p starts with a '+' sign, it does | |
| 1304 nothing; i.e., it leaves its bigfloat argument untouched. | |
| 1305 Therefore, move p past any leading '+' signs. */ | |
| 2010 | 1306 if (*p == '+') |
| 1307 p++; | |
| 1983 | 1308 bigfloat_set_prec (scratch_bigfloat, bigfloat_get_default_prec ()); |
| 1995 | 1309 bigfloat_set_string (scratch_bigfloat, (const char *) p, b); |
| 1983 | 1310 return make_bigfloat_bf (scratch_bigfloat); |
| 1311 } | |
| 1312 #endif | |
| 1313 } | |
| 1314 | |
| 1315 #ifdef HAVE_RATIO | |
| 1316 if (qxestrchr (p, '/') != NULL) | |
| 1317 { | |
| 2013 | 1318 /* The GMP version of ratio_set_string (mpq_set_str) has the following |
| 1319 limitations: | |
| 1320 - If p starts with a '+' sign, it does nothing; i.e., it leaves its | |
| 1321 ratio argument untouched. | |
| 1322 - If p has a '+' sign after the '/' (e.g., 300/+400), it sets the | |
| 1323 numerator from the string, but *leaves the denominator unchanged*. | |
| 1324 - If p has trailing nonnumeric characters, it sets the numerator from | |
| 1325 the string, but leaves the denominator unchanged. | |
| 1326 - If p has more than one '/', (e.g., 1/2/3), then it sets the | |
| 1327 numerator from the string, but leaves the denominator unchanged. | |
| 1328 | |
| 1329 Therefore, move p past any leading '+' signs, temporarily drop a null | |
| 1330 after the numeric characters we are trying to convert, and then put | |
| 1331 the nulled character back afterward. I am not going to fix problem | |
| 1332 #2; just don't write ratios that look like that. */ | |
| 1333 Ibyte *end, save; | |
| 1334 | |
| 2010 | 1335 if (*p == '+') |
| 1336 p++; | |
| 2013 | 1337 |
| 2014 | 1338 end = p; |
| 1339 if (*end == '-') | |
| 1340 end++; | |
| 1341 while ((*end >= '0' && *end <= '9') || | |
| 2013 | 1342 (b > 10 && *end >= 'a' && *end <= 'a' + b - 11) || |
| 2014 | 1343 (b > 10 && *end >= 'A' && *end <= 'A' + b - 11)) |
| 1344 end++; | |
| 2013 | 1345 if (*end == '/') |
| 2014 | 1346 { |
| 1347 end++; | |
| 1348 if (*end == '-') | |
| 1349 end++; | |
| 1350 while ((*end >= '0' && *end <= '9') || | |
| 1351 (b > 10 && *end >= 'a' && *end <= 'a' + b - 11) || | |
| 1352 (b > 10 && *end >= 'A' && *end <= 'A' + b - 11)) | |
| 1353 end++; | |
| 1354 } | |
| 2013 | 1355 save = *end; |
| 1356 *end = '\0'; | |
| 1995 | 1357 ratio_set_string (scratch_ratio, (const char *) p, b); |
| 2013 | 1358 *end = save; |
| 1359 ratio_canonicalize (scratch_ratio); | |
| 1983 | 1360 return make_ratio_rt (scratch_ratio); |
| 1361 } | |
| 1362 #endif /* HAVE_RATIO */ | |
| 1363 | |
| 1364 #ifdef HAVE_BIGNUM | |
| 2013 | 1365 { |
| 1366 /* The GMP version of bignum_set_string (mpz_set_str) has the following | |
| 1367 limitations: | |
| 1368 - If p starts with a '+' sign, it does nothing; i.e., it leaves its | |
| 1369 bignum argument untouched. | |
| 1370 - If p is the empty string, it does nothing. | |
| 1371 - If p has trailing nonnumeric characters, it does nothing. | |
| 1372 | |
| 1373 Therefore, move p past any leading '+' signs, temporarily drop a null | |
| 1374 after the numeric characters we are trying to convert, special case the | |
| 1375 empty string, and then put the nulled character back afterward. */ | |
| 1376 Ibyte *end, save; | |
| 1377 Lisp_Object retval; | |
| 1378 | |
| 1379 if (*p == '+') | |
| 1380 p++; | |
| 2014 | 1381 end = p; |
| 1382 if (*end == '-') | |
| 1383 end++; | |
| 1384 while ((*end >= '0' && *end <= '9') || | |
| 2013 | 1385 (b > 10 && *end >= 'a' && *end <= 'a' + b - 11) || |
| 2014 | 1386 (b > 10 && *end >= 'A' && *end <= 'A' + b - 11)) |
| 1387 end++; | |
| 2013 | 1388 save = *end; |
| 1389 *end = '\0'; | |
| 1390 if (*p == '\0') | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
1391 retval = make_fixnum (0); |
| 2013 | 1392 else |
| 1393 { | |
| 1394 bignum_set_string (scratch_bignum, (const char *) p, b); | |
| 1395 retval = Fcanonicalize_number (make_bignum_bg (scratch_bignum)); | |
| 1396 } | |
| 1397 *end = save; | |
| 1398 return retval; | |
| 1399 } | |
| 1983 | 1400 #else |
| 428 | 1401 if (b == 10) |
| 1402 { | |
| 1403 /* Use the system-provided functions for base 10. */ | |
| 1404 #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
|
1405 return make_fixnum (atoi ((char*) p)); |
| 428 | 1406 #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
|
1407 return make_fixnum (atol ((char*) p)); |
| 428 | 1408 #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
|
1409 return make_fixnum (atoll ((char*) p)); |
| 428 | 1410 #endif |
| 1411 } | |
| 1412 else | |
| 1413 { | |
| 444 | 1414 int negative = 1; |
| 428 | 1415 EMACS_INT v = 0; |
| 1416 | |
| 1417 if (*p == '-') | |
| 1418 { | |
| 1419 negative = -1; | |
| 1420 p++; | |
| 1421 } | |
| 1422 else if (*p == '+') | |
| 1423 p++; | |
| 1424 while (1) | |
| 1425 { | |
| 444 | 1426 int digit = digit_to_number (*p++, b); |
| 428 | 1427 if (digit < 0) |
| 1428 break; | |
| 1429 v = v * b + digit; | |
| 1430 } | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
1431 return make_fixnum (negative * v); |
| 428 | 1432 } |
| 1983 | 1433 #endif /* HAVE_BIGNUM */ |
| 428 | 1434 } |
| 1435 | |
| 1436 | |
| 1437 DEFUN ("+", Fplus, 0, MANY, 0, /* | |
| 1438 Return sum of any number of arguments. | |
| 1439 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
|
1440 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1441 arguments: (&rest ARGS) |
| 428 | 1442 */ |
| 1443 (int nargs, Lisp_Object *args)) | |
| 1444 { | |
| 1983 | 1445 #ifdef WITH_NUMBER_TYPES |
| 1446 REGISTER int i; | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
1447 Lisp_Object accum = make_fixnum (0), addend; |
| 1983 | 1448 |
| 1449 for (i = 0; i < nargs; i++) | |
| 1450 { | |
| 1451 addend = args[i]; | |
| 1452 switch (promote_args (&accum, &addend)) | |
| 1453 { | |
| 1454 case FIXNUM_T: | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
1455 accum = make_integer (XREALFIXNUM (accum) + XREALFIXNUM (addend)); |
| 1983 | 1456 break; |
| 1457 #ifdef HAVE_BIGNUM | |
| 1458 case BIGNUM_T: | |
|
5736
3192994c49ca
Convert C (un)signed long long values to bignums properly.
Jerry James <james@xemacs.org>
parents:
5582
diff
changeset
|
1459 bignum_add (XBIGNUM_DATA (accum), XBIGNUM_DATA (accum), |
| 1983 | 1460 XBIGNUM_DATA (addend)); |
| 1461 break; | |
| 1462 #endif | |
| 1463 #ifdef HAVE_RATIO | |
| 1464 case RATIO_T: | |
|
5736
3192994c49ca
Convert C (un)signed long long values to bignums properly.
Jerry James <james@xemacs.org>
parents:
5582
diff
changeset
|
1465 ratio_add (XRATIO_DATA (accum), XRATIO_DATA (accum), |
| 1983 | 1466 XRATIO_DATA (addend)); |
| 1467 break; | |
| 1468 #endif | |
| 1469 case FLOAT_T: | |
| 1470 accum = make_float (XFLOAT_DATA (accum) + XFLOAT_DATA (addend)); | |
| 1471 break; | |
| 1472 #ifdef HAVE_BIGFLOAT | |
| 1473 case BIGFLOAT_T: | |
|
5736
3192994c49ca
Convert C (un)signed long long values to bignums properly.
Jerry James <james@xemacs.org>
parents:
5582
diff
changeset
|
1474 bigfloat_set_prec (XBIGFLOAT_DATA (accum), |
| 1983 | 1475 max (XBIGFLOAT_GET_PREC (addend), |
| 1476 XBIGFLOAT_GET_PREC (accum))); | |
|
5736
3192994c49ca
Convert C (un)signed long long values to bignums properly.
Jerry James <james@xemacs.org>
parents:
5582
diff
changeset
|
1477 bigfloat_add (XBIGFLOAT_DATA (accum), XBIGFLOAT_DATA (accum), |
| 1983 | 1478 XBIGFLOAT_DATA (addend)); |
| 1479 break; | |
| 1480 #endif | |
| 1481 } | |
| 1482 } | |
| 1483 return Fcanonicalize_number (accum); | |
| 1484 #else /* !WITH_NUMBER_TYPES */ | |
| 428 | 1485 EMACS_INT iaccum = 0; |
| 1486 Lisp_Object *args_end = args + nargs; | |
| 1487 | |
| 1488 while (args < args_end) | |
| 1489 { | |
| 1490 int_or_double iod; | |
| 1491 number_char_or_marker_to_int_or_double (*args++, &iod); | |
| 1492 if (iod.int_p) | |
| 1493 iaccum += iod.c.ival; | |
| 1494 else | |
| 1495 { | |
| 1496 double daccum = (double) iaccum + iod.c.dval; | |
| 1497 while (args < args_end) | |
| 1498 daccum += number_char_or_marker_to_double (*args++); | |
| 1499 return make_float (daccum); | |
| 1500 } | |
| 1501 } | |
| 1502 | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
1503 return make_fixnum (iaccum); |
| 1983 | 1504 #endif /* WITH_NUMBER_TYPES */ |
| 428 | 1505 } |
| 1506 | |
| 1507 DEFUN ("-", Fminus, 1, MANY, 0, /* | |
| 1508 Negate number or subtract numbers, characters or markers. | |
| 1509 With one arg, negates it. With more than one arg, | |
| 1510 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
|
1511 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1512 arguments: (FIRST &rest ARGS) |
| 428 | 1513 */ |
| 1514 (int nargs, Lisp_Object *args)) | |
| 1515 { | |
| 1983 | 1516 #ifdef WITH_NUMBER_TYPES |
| 1517 REGISTER int i; | |
| 1518 Lisp_Object accum = args[0], subtrahend; | |
| 1519 | |
| 1520 if (nargs == 1) | |
| 1521 { | |
| 1522 if (CHARP (accum)) | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
1523 accum = make_fixnum (XCHAR (accum)); |
| 1983 | 1524 else if (MARKERP (accum)) |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
1525 accum = make_fixnum (marker_position (accum)); |
| 1983 | 1526 |
| 1527 /* Invert the sign of accum */ | |
| 1528 CHECK_NUMBER (accum); | |
| 1529 switch (get_number_type (accum)) | |
| 1530 { | |
| 1531 case FIXNUM_T: | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
1532 return make_integer (-XREALFIXNUM (accum)); |
| 1983 | 1533 #ifdef HAVE_BIGNUM |
| 1534 case BIGNUM_T: | |
| 1535 bignum_neg (scratch_bignum, XBIGNUM_DATA (accum)); | |
| 1536 return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); | |
| 1537 #endif | |
| 1538 #ifdef HAVE_RATIO | |
| 1539 case RATIO_T: | |
| 1540 ratio_neg (scratch_ratio, XRATIO_DATA (accum)); | |
| 1541 return make_ratio_rt (scratch_ratio); | |
| 1542 #endif | |
| 1543 case FLOAT_T: | |
| 1544 return make_float (-XFLOAT_DATA (accum)); | |
| 1545 #ifdef HAVE_BIGFLOAT | |
| 1546 case BIGFLOAT_T: | |
| 1547 bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (accum)); | |
| 1548 bigfloat_neg (scratch_bigfloat, XBIGFLOAT_DATA (accum)); | |
| 1549 return make_bigfloat_bf (scratch_bigfloat); | |
| 1550 #endif | |
| 1551 } | |
| 1552 } | |
| 1553 else | |
| 1554 { | |
| 1555 /* Subtrace the remaining arguments from accum */ | |
| 1556 for (i = 1; i < nargs; i++) | |
| 1557 { | |
| 1558 subtrahend = args[i]; | |
| 1559 switch (promote_args (&accum, &subtrahend)) | |
| 1560 { | |
| 1561 case FIXNUM_T: | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
1562 accum = make_integer (XREALFIXNUM (accum) - XREALFIXNUM (subtrahend)); |
| 1983 | 1563 break; |
| 1564 #ifdef HAVE_BIGNUM | |
| 1565 case BIGNUM_T: | |
| 1566 bignum_sub (scratch_bignum, XBIGNUM_DATA (accum), | |
| 1567 XBIGNUM_DATA (subtrahend)); | |
| 1568 accum = make_bignum_bg (scratch_bignum); | |
| 1569 break; | |
| 1570 #endif | |
| 1571 #ifdef HAVE_RATIO | |
| 1572 case RATIO_T: | |
| 1573 ratio_sub (scratch_ratio, XRATIO_DATA (accum), | |
| 1574 XRATIO_DATA (subtrahend)); | |
| 1575 accum = make_ratio_rt (scratch_ratio); | |
| 1576 break; | |
| 1577 #endif | |
| 1578 case FLOAT_T: | |
| 1579 accum = | |
| 1580 make_float (XFLOAT_DATA (accum) - XFLOAT_DATA (subtrahend)); | |
| 1581 break; | |
| 1582 #ifdef HAVE_BIGFLOAT | |
| 1583 case BIGFLOAT_T: | |
| 1584 bigfloat_set_prec (scratch_bigfloat, | |
| 1585 max (XBIGFLOAT_GET_PREC (subtrahend), | |
| 1586 XBIGFLOAT_GET_PREC (accum))); | |
| 1587 bigfloat_sub (scratch_bigfloat, XBIGFLOAT_DATA (accum), | |
| 1588 XBIGFLOAT_DATA (subtrahend)); | |
| 1589 accum = make_bigfloat_bf (scratch_bigfloat); | |
| 1590 break; | |
| 1591 #endif | |
| 1592 } | |
| 1593 } | |
| 1594 } | |
| 1595 return Fcanonicalize_number (accum); | |
| 1596 #else /* !WITH_NUMBER_TYPES */ | |
| 428 | 1597 EMACS_INT iaccum; |
| 1598 double daccum; | |
| 1599 Lisp_Object *args_end = args + nargs; | |
| 1600 int_or_double iod; | |
| 1601 | |
| 1602 number_char_or_marker_to_int_or_double (*args++, &iod); | |
| 1603 if (iod.int_p) | |
| 1604 iaccum = nargs > 1 ? iod.c.ival : - iod.c.ival; | |
| 1605 else | |
| 1606 { | |
| 1607 daccum = nargs > 1 ? iod.c.dval : - iod.c.dval; | |
| 1608 goto do_float; | |
| 1609 } | |
| 1610 | |
| 1611 while (args < args_end) | |
| 1612 { | |
| 1613 number_char_or_marker_to_int_or_double (*args++, &iod); | |
| 1614 if (iod.int_p) | |
| 1615 iaccum -= iod.c.ival; | |
| 1616 else | |
| 1617 { | |
| 1618 daccum = (double) iaccum - iod.c.dval; | |
| 1619 goto do_float; | |
| 1620 } | |
| 1621 } | |
| 1622 | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
1623 return make_fixnum (iaccum); |
| 428 | 1624 |
| 1625 do_float: | |
| 1626 for (; args < args_end; args++) | |
| 1627 daccum -= number_char_or_marker_to_double (*args); | |
| 1628 return make_float (daccum); | |
| 1983 | 1629 #endif /* WITH_NUMBER_TYPES */ |
| 428 | 1630 } |
| 1631 | |
| 1632 DEFUN ("*", Ftimes, 0, MANY, 0, /* | |
| 1633 Return product of any number of arguments. | |
| 1634 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
|
1635 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1636 arguments: (&rest ARGS) |
| 428 | 1637 */ |
| 1638 (int nargs, Lisp_Object *args)) | |
| 1639 { | |
| 1983 | 1640 #ifdef WITH_NUMBER_TYPES |
| 1641 REGISTER int i; | |
| 1642 /* Start with a bignum to avoid overflow */ | |
| 1643 Lisp_Object accum = make_bignum (1L), multiplier; | |
| 1644 | |
| 1645 for (i = 0; i < nargs; i++) | |
| 1646 { | |
| 1647 multiplier = args[i]; | |
| 1648 switch (promote_args (&accum, &multiplier)) | |
| 1649 { | |
| 1650 #ifdef HAVE_BIGNUM | |
| 1651 case BIGNUM_T: | |
|
5736
3192994c49ca
Convert C (un)signed long long values to bignums properly.
Jerry James <james@xemacs.org>
parents:
5582
diff
changeset
|
1652 bignum_mul (XBIGNUM_DATA (accum), XBIGNUM_DATA (accum), |
| 1983 | 1653 XBIGNUM_DATA (multiplier)); |
| 1654 break; | |
| 1655 #endif | |
| 1656 #ifdef HAVE_RATIO | |
| 1657 case RATIO_T: | |
|
5736
3192994c49ca
Convert C (un)signed long long values to bignums properly.
Jerry James <james@xemacs.org>
parents:
5582
diff
changeset
|
1658 ratio_mul (XRATIO_DATA (accum), XRATIO_DATA (accum), |
| 1983 | 1659 XRATIO_DATA (multiplier)); |
| 1660 break; | |
| 1661 #endif | |
| 1662 case FLOAT_T: | |
| 1663 accum = make_float (XFLOAT_DATA (accum) * XFLOAT_DATA (multiplier)); | |
| 1664 break; | |
| 1665 #ifdef HAVE_BIGFLOAT | |
| 1666 case BIGFLOAT_T: | |
|
5736
3192994c49ca
Convert C (un)signed long long values to bignums properly.
Jerry James <james@xemacs.org>
parents:
5582
diff
changeset
|
1667 bigfloat_set_prec (XBIGFLOAT_DATA (accum), |
| 1983 | 1668 max (XBIGFLOAT_GET_PREC (multiplier), |
| 1669 XBIGFLOAT_GET_PREC (accum))); | |
|
5736
3192994c49ca
Convert C (un)signed long long values to bignums properly.
Jerry James <james@xemacs.org>
parents:
5582
diff
changeset
|
1670 bigfloat_mul (XBIGFLOAT_DATA (accum), XBIGFLOAT_DATA (accum), |
| 1983 | 1671 XBIGFLOAT_DATA (multiplier)); |
| 1672 break; | |
| 1673 #endif | |
| 1674 } | |
| 1675 } | |
| 1676 return Fcanonicalize_number (accum); | |
| 1677 #else /* !WITH_NUMBER_TYPES */ | |
| 428 | 1678 EMACS_INT iaccum = 1; |
| 1679 Lisp_Object *args_end = args + nargs; | |
| 1680 | |
| 1681 while (args < args_end) | |
| 1682 { | |
| 1683 int_or_double iod; | |
| 1684 number_char_or_marker_to_int_or_double (*args++, &iod); | |
| 1685 if (iod.int_p) | |
| 1686 iaccum *= iod.c.ival; | |
| 1687 else | |
| 1688 { | |
| 1689 double daccum = (double) iaccum * iod.c.dval; | |
| 1690 while (args < args_end) | |
| 1691 daccum *= number_char_or_marker_to_double (*args++); | |
| 1692 return make_float (daccum); | |
| 1693 } | |
| 1694 } | |
| 1695 | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
1696 return make_fixnum (iaccum); |
| 1983 | 1697 #endif /* WITH_NUMBER_TYPES */ |
| 428 | 1698 } |
| 1699 | |
| 1983 | 1700 #ifdef HAVE_RATIO |
| 1701 DEFUN ("div", Fdiv, 1, MANY, 0, /* | |
| 1702 Same as `/', but dividing integers creates a ratio instead of truncating. | |
| 1703 Note that this is a departure from Common Lisp, where / creates ratios when | |
| 1704 dividing integers. Having a separate function lets us avoid breaking existing | |
| 1705 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
|
1706 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1707 arguments: (FIRST &rest ARGS) |
| 1983 | 1708 */ |
| 1709 (int nargs, Lisp_Object *args)) | |
| 1710 { | |
| 1711 REGISTER int i; | |
| 1712 Lisp_Object accum, divisor; | |
| 1713 | |
| 1714 if (nargs == 1) | |
| 1715 { | |
| 1716 i = 0; | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
1717 accum = make_fixnum (1); |
| 1983 | 1718 } |
| 1719 else | |
| 1720 { | |
| 1721 i = 1; | |
| 1722 accum = args[0]; | |
| 1723 } | |
| 1724 for (; i < nargs; i++) | |
| 1725 { | |
| 1726 divisor = args[i]; | |
| 1727 switch (promote_args (&accum, &divisor)) | |
| 1728 { | |
| 1729 case FIXNUM_T: | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
1730 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
|
1731 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
|
1732 bignum_set_long (scratch_bignum2, XREALFIXNUM (divisor)); |
| 1983 | 1733 accum = make_ratio_bg (scratch_bignum, scratch_bignum2); |
| 1734 break; | |
| 1735 case BIGNUM_T: | |
| 1736 if (bignum_sign (XBIGNUM_DATA (divisor)) == 0) goto divide_by_zero; | |
| 1737 accum = make_ratio_bg (XBIGNUM_DATA (accum), XBIGNUM_DATA (divisor)); | |
| 1738 break; | |
| 1739 case RATIO_T: | |
| 1740 if (ratio_sign (XRATIO_DATA (divisor)) == 0) goto divide_by_zero; | |
| 1741 ratio_div (scratch_ratio, XRATIO_DATA (accum), | |
| 1742 XRATIO_DATA (divisor)); | |
| 1743 accum = make_ratio_rt (scratch_ratio); | |
| 1744 break; | |
| 1745 case FLOAT_T: | |
| 1746 if (XFLOAT_DATA (divisor) == 0.0) goto divide_by_zero; | |
| 1747 accum = make_float (XFLOAT_DATA (accum) / XFLOAT_DATA (divisor)); | |
| 1748 break; | |
| 1749 #ifdef HAVE_BIGFLOAT | |
| 1750 case BIGFLOAT_T: | |
| 1751 if (bigfloat_sign (XBIGFLOAT_DATA (divisor)) == 0) | |
| 1752 goto divide_by_zero; | |
| 1753 bigfloat_set_prec (scratch_bigfloat, | |
| 1754 max (XBIGFLOAT_GET_PREC (divisor), | |
| 1755 XBIGFLOAT_GET_PREC (accum))); | |
| 1756 bigfloat_div (scratch_bigfloat, XBIGFLOAT_DATA (accum), | |
| 1757 XBIGFLOAT_DATA (divisor)); | |
| 1758 accum = make_bigfloat_bf (scratch_bigfloat); | |
| 1759 break; | |
| 1760 #endif | |
| 1761 } | |
| 1762 } | |
| 1763 return Fcanonicalize_number (accum); | |
| 1764 | |
| 1765 divide_by_zero: | |
| 1766 Fsignal (Qarith_error, Qnil); | |
| 1767 return Qnil; /* not (usually) reached */ | |
| 1768 } | |
| 1769 #endif /* HAVE_RATIO */ | |
| 1770 | |
| 428 | 1771 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
|
1772 Return FIRST divided by all the remaining arguments. |
| 428 | 1773 The arguments must be numbers, characters or markers. |
| 1774 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
|
1775 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1776 arguments: (FIRST &rest ARGS) |
| 428 | 1777 */ |
| 1778 (int nargs, Lisp_Object *args)) | |
| 1779 { | |
| 1983 | 1780 #ifdef WITH_NUMBER_TYPES |
| 1781 REGISTER int i; | |
| 1782 Lisp_Object accum, divisor; | |
| 1783 | |
| 1784 if (nargs == 1) | |
| 1785 { | |
| 1786 i = 0; | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
1787 accum = make_fixnum (1); |
| 1983 | 1788 } |
| 1789 else | |
| 1790 { | |
| 1791 i = 1; | |
| 1792 accum = args[0]; | |
| 1793 } | |
| 1794 for (; i < nargs; i++) | |
| 1795 { | |
| 1796 divisor = args[i]; | |
| 1797 switch (promote_args (&accum, &divisor)) | |
| 1798 { | |
| 1799 case FIXNUM_T: | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
1800 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
|
1801 accum = make_integer (XREALFIXNUM (accum) / XREALFIXNUM (divisor)); |
| 1983 | 1802 break; |
| 1803 #ifdef HAVE_BIGNUM | |
| 1804 case BIGNUM_T: | |
| 1805 if (bignum_sign (XBIGNUM_DATA (divisor)) == 0) goto divide_by_zero; | |
| 1806 bignum_div (scratch_bignum, XBIGNUM_DATA (accum), | |
| 1807 XBIGNUM_DATA (divisor)); | |
| 1808 accum = make_bignum_bg (scratch_bignum); | |
| 1809 break; | |
| 1810 #endif | |
| 1811 #ifdef HAVE_RATIO | |
| 1812 case RATIO_T: | |
| 1813 if (ratio_sign (XRATIO_DATA (divisor)) == 0) goto divide_by_zero; | |
| 1814 ratio_div (scratch_ratio, XRATIO_DATA (accum), | |
| 1815 XRATIO_DATA (divisor)); | |
| 1816 accum = make_ratio_rt (scratch_ratio); | |
| 1817 break; | |
| 1818 #endif | |
| 1819 case FLOAT_T: | |
| 1820 if (XFLOAT_DATA (divisor) == 0.0) goto divide_by_zero; | |
| 1821 accum = make_float (XFLOAT_DATA (accum) / XFLOAT_DATA (divisor)); | |
| 1822 break; | |
| 1823 #ifdef HAVE_BIGFLOAT | |
| 1824 case BIGFLOAT_T: | |
| 1825 if (bigfloat_sign (XBIGFLOAT_DATA (divisor)) == 0) | |
| 1826 goto divide_by_zero; | |
| 1827 bigfloat_set_prec (scratch_bigfloat, | |
| 1828 max (XBIGFLOAT_GET_PREC (divisor), | |
| 1829 XBIGFLOAT_GET_PREC (accum))); | |
| 1830 bigfloat_div (scratch_bigfloat, XBIGFLOAT_DATA (accum), | |
| 1831 XBIGFLOAT_DATA (divisor)); | |
| 1832 accum = make_bigfloat_bf (scratch_bigfloat); | |
| 1833 break; | |
| 1834 #endif | |
| 1835 } | |
| 1836 } | |
| 1837 return Fcanonicalize_number (accum); | |
| 1838 #else /* !WITH_NUMBER_TYPES */ | |
| 428 | 1839 EMACS_INT iaccum; |
| 1840 double daccum; | |
| 1841 Lisp_Object *args_end = args + nargs; | |
| 1842 int_or_double iod; | |
| 1843 | |
| 1844 if (nargs == 1) | |
| 1845 iaccum = 1; | |
| 1846 else | |
| 1847 { | |
| 1848 number_char_or_marker_to_int_or_double (*args++, &iod); | |
| 1849 if (iod.int_p) | |
| 1850 iaccum = iod.c.ival; | |
| 1851 else | |
| 1852 { | |
| 1853 daccum = iod.c.dval; | |
| 1854 goto divide_floats; | |
| 1855 } | |
| 1856 } | |
| 1857 | |
| 1858 while (args < args_end) | |
| 1859 { | |
| 1860 number_char_or_marker_to_int_or_double (*args++, &iod); | |
| 1861 if (iod.int_p) | |
| 1862 { | |
| 1863 if (iod.c.ival == 0) goto divide_by_zero; | |
| 1864 iaccum /= iod.c.ival; | |
| 1865 } | |
| 1866 else | |
| 1867 { | |
| 1868 if (iod.c.dval == 0) goto divide_by_zero; | |
| 1869 daccum = (double) iaccum / iod.c.dval; | |
| 1870 goto divide_floats; | |
| 1871 } | |
| 1872 } | |
| 1873 | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
1874 return make_fixnum (iaccum); |
| 428 | 1875 |
| 1876 divide_floats: | |
| 1877 for (; args < args_end; args++) | |
| 1878 { | |
| 1879 double dval = number_char_or_marker_to_double (*args); | |
| 1880 if (dval == 0) goto divide_by_zero; | |
| 1881 daccum /= dval; | |
| 1882 } | |
| 1883 return make_float (daccum); | |
| 1983 | 1884 #endif /* WITH_NUMBER_TYPES */ |
| 428 | 1885 |
| 1886 divide_by_zero: | |
| 1887 Fsignal (Qarith_error, Qnil); | |
| 801 | 1888 return Qnil; /* not (usually) reached */ |
| 428 | 1889 } |
| 1890 | |
| 1891 DEFUN ("max", Fmax, 1, MANY, 0, /* | |
| 1892 Return largest of all the arguments. | |
| 1983 | 1893 All arguments must be real numbers, characters or markers. |
| 428 | 1894 The value is always a number; markers and characters are converted |
| 1895 to numbers. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1896 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1897 arguments: (FIRST &rest ARGS) |
| 428 | 1898 */ |
| 1899 (int nargs, Lisp_Object *args)) | |
| 1900 { | |
| 1983 | 1901 #ifdef WITH_NUMBER_TYPES |
| 1902 REGISTER int i, maxindex = 0; | |
| 1903 | |
| 1904 while (!(CHARP (args[0]) || MARKERP (args[0]) || REALP (args[0]))) | |
| 1905 args[0] = wrong_type_argument (Qnumber_char_or_marker_p, args[0]); | |
| 1906 if (CHARP (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 (XCHAR (args[0])); |
| 1983 | 1908 else if (MARKERP (args[0])) |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
1909 args[0] = make_fixnum (marker_position (args[0])); |
| 1983 | 1910 for (i = 1; i < nargs; i++) |
| 1911 { | |
|
5768
3bfcdeb65578
Return a fixnum as documented with marker arg, #'max, #'min
Aidan Kehoe <kehoea@parhasard.net>
parents:
5762
diff
changeset
|
1912 switch (promote_args (args + maxindex, args + i)) |
| 1983 | 1913 { |
| 1914 case FIXNUM_T: | |
|
5768
3bfcdeb65578
Return a fixnum as documented with marker arg, #'max, #'min
Aidan Kehoe <kehoea@parhasard.net>
parents:
5762
diff
changeset
|
1915 if (XREALFIXNUM (args[maxindex]) < XREALFIXNUM (args[i])) |
| 1983 | 1916 maxindex = i; |
| 1917 break; | |
| 1918 #ifdef HAVE_BIGNUM | |
| 1919 case BIGNUM_T: | |
|
5768
3bfcdeb65578
Return a fixnum as documented with marker arg, #'max, #'min
Aidan Kehoe <kehoea@parhasard.net>
parents:
5762
diff
changeset
|
1920 if (bignum_lt (XBIGNUM_DATA (args[maxindex]), |
|
3bfcdeb65578
Return a fixnum as documented with marker arg, #'max, #'min
Aidan Kehoe <kehoea@parhasard.net>
parents:
5762
diff
changeset
|
1921 XBIGNUM_DATA (args[i]))) |
| 1983 | 1922 maxindex = i; |
| 1923 break; | |
| 1924 #endif | |
| 1925 #ifdef HAVE_RATIO | |
| 1926 case RATIO_T: | |
|
5768
3bfcdeb65578
Return a fixnum as documented with marker arg, #'max, #'min
Aidan Kehoe <kehoea@parhasard.net>
parents:
5762
diff
changeset
|
1927 if (ratio_lt (XRATIO_DATA (args[maxindex]), XRATIO_DATA (args[i]))) |
| 1983 | 1928 maxindex = i; |
| 1929 break; | |
| 1930 #endif | |
| 1931 case FLOAT_T: | |
|
5768
3bfcdeb65578
Return a fixnum as documented with marker arg, #'max, #'min
Aidan Kehoe <kehoea@parhasard.net>
parents:
5762
diff
changeset
|
1932 if (XFLOAT_DATA (args[maxindex]) < XFLOAT_DATA (args[i])) |
| 1983 | 1933 maxindex = i; |
| 1934 break; | |
| 1935 #ifdef HAVE_BIGFLOAT | |
| 1936 case BIGFLOAT_T: | |
|
5768
3bfcdeb65578
Return a fixnum as documented with marker arg, #'max, #'min
Aidan Kehoe <kehoea@parhasard.net>
parents:
5762
diff
changeset
|
1937 if (bigfloat_lt (XBIGFLOAT_DATA (args[maxindex]), |
|
3bfcdeb65578
Return a fixnum as documented with marker arg, #'max, #'min
Aidan Kehoe <kehoea@parhasard.net>
parents:
5762
diff
changeset
|
1938 XBIGFLOAT_DATA (args[i]))) |
| 1983 | 1939 maxindex = i; |
| 1940 break; | |
| 1941 #endif | |
| 1942 } | |
| 1943 } | |
| 1944 return args[maxindex]; | |
| 1945 #else /* !WITH_NUMBER_TYPES */ | |
| 428 | 1946 EMACS_INT imax; |
| 1947 double dmax; | |
| 1948 Lisp_Object *args_end = args + nargs; | |
| 1949 int_or_double iod; | |
| 1950 | |
| 1951 number_char_or_marker_to_int_or_double (*args++, &iod); | |
| 1952 if (iod.int_p) | |
| 1953 imax = iod.c.ival; | |
| 1954 else | |
| 1955 { | |
| 1956 dmax = iod.c.dval; | |
| 1957 goto max_floats; | |
| 1958 } | |
| 1959 | |
| 1960 while (args < args_end) | |
| 1961 { | |
| 1962 number_char_or_marker_to_int_or_double (*args++, &iod); | |
| 1963 if (iod.int_p) | |
| 1964 { | |
| 1965 if (imax < iod.c.ival) imax = iod.c.ival; | |
| 1966 } | |
| 1967 else | |
| 1968 { | |
| 1969 dmax = (double) imax; | |
| 1970 if (dmax < iod.c.dval) dmax = iod.c.dval; | |
| 1971 goto max_floats; | |
| 1972 } | |
| 1973 } | |
| 1974 | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
1975 return make_fixnum (imax); |
| 428 | 1976 |
| 1977 max_floats: | |
| 1978 while (args < args_end) | |
| 1979 { | |
| 1980 double dval = number_char_or_marker_to_double (*args++); | |
| 1981 if (dmax < dval) dmax = dval; | |
| 1982 } | |
| 1983 return make_float (dmax); | |
| 1983 | 1984 #endif /* WITH_NUMBER_TYPES */ |
| 428 | 1985 } |
| 1986 | |
| 1987 DEFUN ("min", Fmin, 1, MANY, 0, /* | |
| 1988 Return smallest of all the arguments. | |
| 1989 All arguments must be numbers, characters or markers. | |
| 1990 The value is always a number; markers and characters are converted | |
| 1991 to numbers. | |
|
4693
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1992 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
1993 arguments: (FIRST &rest ARGS) |
| 428 | 1994 */ |
| 1995 (int nargs, Lisp_Object *args)) | |
| 1996 { | |
| 1983 | 1997 #ifdef WITH_NUMBER_TYPES |
| 1998 REGISTER int i, minindex = 0; | |
| 1999 | |
| 2000 while (!(CHARP (args[0]) || MARKERP (args[0]) || REALP (args[0]))) | |
| 2001 args[0] = wrong_type_argument (Qnumber_char_or_marker_p, args[0]); | |
| 2002 if (CHARP (args[0])) | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2003 args[0] = make_fixnum (XCHAR (args[0])); |
| 1983 | 2004 else if (MARKERP (args[0])) |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2005 args[0] = make_fixnum (marker_position (args[0])); |
| 1983 | 2006 for (i = 1; i < nargs; i++) |
| 2007 { | |
|
5768
3bfcdeb65578
Return a fixnum as documented with marker arg, #'max, #'min
Aidan Kehoe <kehoea@parhasard.net>
parents:
5762
diff
changeset
|
2008 switch (promote_args (args + minindex, args + i)) |
| 1983 | 2009 { |
| 2010 case FIXNUM_T: | |
|
5768
3bfcdeb65578
Return a fixnum as documented with marker arg, #'max, #'min
Aidan Kehoe <kehoea@parhasard.net>
parents:
5762
diff
changeset
|
2011 if (XREALFIXNUM (args[minindex]) > XREALFIXNUM (args[i])) |
| 1983 | 2012 minindex = i; |
| 2013 break; | |
| 2014 #ifdef HAVE_BIGNUM | |
| 2015 case BIGNUM_T: | |
|
5768
3bfcdeb65578
Return a fixnum as documented with marker arg, #'max, #'min
Aidan Kehoe <kehoea@parhasard.net>
parents:
5762
diff
changeset
|
2016 if (bignum_gt (XBIGNUM_DATA (args[minindex]), |
|
3bfcdeb65578
Return a fixnum as documented with marker arg, #'max, #'min
Aidan Kehoe <kehoea@parhasard.net>
parents:
5762
diff
changeset
|
2017 XBIGNUM_DATA (args[i]))) |
| 1983 | 2018 minindex = i; |
| 2019 break; | |
| 2020 #endif | |
| 2021 #ifdef HAVE_RATIO | |
| 2022 case RATIO_T: | |
|
5768
3bfcdeb65578
Return a fixnum as documented with marker arg, #'max, #'min
Aidan Kehoe <kehoea@parhasard.net>
parents:
5762
diff
changeset
|
2023 if (ratio_gt (XRATIO_DATA (args[minindex]), |
|
3bfcdeb65578
Return a fixnum as documented with marker arg, #'max, #'min
Aidan Kehoe <kehoea@parhasard.net>
parents:
5762
diff
changeset
|
2024 XRATIO_DATA (args[i]))) |
| 1983 | 2025 minindex = i; |
| 2026 break; | |
| 2027 #endif | |
| 2028 case FLOAT_T: | |
|
5768
3bfcdeb65578
Return a fixnum as documented with marker arg, #'max, #'min
Aidan Kehoe <kehoea@parhasard.net>
parents:
5762
diff
changeset
|
2029 if (XFLOAT_DATA (args[minindex]) > XFLOAT_DATA (args[i])) |
| 1983 | 2030 minindex = i; |
| 2031 break; | |
| 2032 #ifdef HAVE_BIGFLOAT | |
| 2033 case BIGFLOAT_T: | |
|
5768
3bfcdeb65578
Return a fixnum as documented with marker arg, #'max, #'min
Aidan Kehoe <kehoea@parhasard.net>
parents:
5762
diff
changeset
|
2034 if (bigfloat_gt (XBIGFLOAT_DATA (args[minindex]), |
|
3bfcdeb65578
Return a fixnum as documented with marker arg, #'max, #'min
Aidan Kehoe <kehoea@parhasard.net>
parents:
5762
diff
changeset
|
2035 XBIGFLOAT_DATA (args[i]))) |
| 1983 | 2036 minindex = i; |
| 2037 break; | |
| 2038 #endif | |
| 2039 } | |
| 2040 } | |
| 2041 return args[minindex]; | |
| 2042 #else /* !WITH_NUMBER_TYPES */ | |
| 428 | 2043 EMACS_INT imin; |
| 2044 double dmin; | |
| 2045 Lisp_Object *args_end = args + nargs; | |
| 2046 int_or_double iod; | |
| 2047 | |
| 2048 number_char_or_marker_to_int_or_double (*args++, &iod); | |
| 2049 if (iod.int_p) | |
| 2050 imin = iod.c.ival; | |
| 2051 else | |
| 2052 { | |
| 2053 dmin = iod.c.dval; | |
| 2054 goto min_floats; | |
| 2055 } | |
| 2056 | |
| 2057 while (args < args_end) | |
| 2058 { | |
| 2059 number_char_or_marker_to_int_or_double (*args++, &iod); | |
| 2060 if (iod.int_p) | |
| 2061 { | |
| 2062 if (imin > iod.c.ival) imin = iod.c.ival; | |
| 2063 } | |
| 2064 else | |
| 2065 { | |
| 2066 dmin = (double) imin; | |
| 2067 if (dmin > iod.c.dval) dmin = iod.c.dval; | |
| 2068 goto min_floats; | |
| 2069 } | |
| 2070 } | |
| 2071 | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2072 return make_fixnum (imin); |
| 428 | 2073 |
| 2074 min_floats: | |
| 2075 while (args < args_end) | |
| 2076 { | |
| 2077 double dval = number_char_or_marker_to_double (*args++); | |
| 2078 if (dmin > dval) dmin = dval; | |
| 2079 } | |
| 2080 return make_float (dmin); | |
| 1983 | 2081 #endif /* WITH_NUMBER_TYPES */ |
| 428 | 2082 } |
| 2083 | |
| 2084 DEFUN ("logand", Flogand, 0, MANY, 0, /* | |
| 2085 Return bitwise-and of all the arguments. | |
| 2086 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
|
2087 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
2088 arguments: (&rest ARGS) |
| 428 | 2089 */ |
| 2090 (int nargs, Lisp_Object *args)) | |
| 2091 { | |
| 1983 | 2092 #ifdef HAVE_BIGNUM |
| 2093 REGISTER int i; | |
| 2094 Lisp_Object result, other; | |
| 2095 | |
| 2096 if (nargs == 0) | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2097 return make_fixnum (~0); |
| 1983 | 2098 |
| 2099 while (!(CHARP (args[0]) || MARKERP (args[0]) || INTEGERP (args[0]))) | |
| 2100 args[0] = wrong_type_argument (Qnumber_char_or_marker_p, args[0]); | |
| 2101 | |
| 2102 result = args[0]; | |
| 2103 if (CHARP (result)) | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2104 result = make_fixnum (XCHAR (result)); |
| 1983 | 2105 else if (MARKERP (result)) |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2106 result = make_fixnum (marker_position (result)); |
| 1983 | 2107 for (i = 1; i < nargs; i++) |
| 2108 { | |
| 2109 while (!(CHARP (args[i]) || MARKERP (args[i]) || INTEGERP (args[i]))) | |
| 2110 args[i] = wrong_type_argument (Qnumber_char_or_marker_p, args[i]); | |
| 2111 other = args[i]; | |
| 1995 | 2112 switch (promote_args (&result, &other)) |
| 1983 | 2113 { |
| 2114 case FIXNUM_T: | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2115 result = make_fixnum (XREALFIXNUM (result) & XREALFIXNUM (other)); |
| 1983 | 2116 break; |
| 2117 case BIGNUM_T: | |
| 2118 bignum_and (scratch_bignum, XBIGNUM_DATA (result), | |
| 2119 XBIGNUM_DATA (other)); | |
| 2120 result = make_bignum_bg (scratch_bignum); | |
| 2121 break; | |
| 2122 } | |
| 2123 } | |
| 2124 return Fcanonicalize_number (result); | |
| 2125 #else /* !HAVE_BIGNUM */ | |
| 428 | 2126 EMACS_INT bits = ~0; |
| 2127 Lisp_Object *args_end = args + nargs; | |
| 2128 | |
| 2129 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
|
2130 bits &= fixnum_char_or_marker_to_int (*args++); |
| 428 | 2131 |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2132 return make_fixnum (bits); |
| 1983 | 2133 #endif /* HAVE_BIGNUM */ |
| 428 | 2134 } |
| 2135 | |
| 2136 DEFUN ("logior", Flogior, 0, MANY, 0, /* | |
| 2137 Return bitwise-or of all the arguments. | |
| 2138 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
|
2139 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
2140 arguments: (&rest ARGS) |
| 428 | 2141 */ |
| 2142 (int nargs, Lisp_Object *args)) | |
| 2143 { | |
| 1983 | 2144 #ifdef HAVE_BIGNUM |
| 2145 REGISTER int i; | |
| 2146 Lisp_Object result, other; | |
| 2147 | |
| 2148 if (nargs == 0) | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2149 return make_fixnum (0); |
| 1983 | 2150 |
| 2151 while (!(CHARP (args[0]) || MARKERP (args[0]) || INTEGERP (args[0]))) | |
| 2152 args[0] = wrong_type_argument (Qnumber_char_or_marker_p, args[0]); | |
| 2153 | |
| 2154 result = args[0]; | |
| 2155 if (CHARP (result)) | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2156 result = make_fixnum (XCHAR (result)); |
| 1983 | 2157 else if (MARKERP (result)) |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2158 result = make_fixnum (marker_position (result)); |
| 1983 | 2159 for (i = 1; i < nargs; i++) |
| 2160 { | |
| 2161 while (!(CHARP (args[i]) || MARKERP (args[i]) || INTEGERP (args[i]))) | |
| 2162 args[i] = wrong_type_argument (Qnumber_char_or_marker_p, args[i]); | |
| 2163 other = args[i]; | |
| 2164 switch (promote_args (&result, &other)) | |
| 2165 { | |
| 2166 case FIXNUM_T: | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2167 result = make_fixnum (XREALFIXNUM (result) | XREALFIXNUM (other)); |
| 1983 | 2168 break; |
| 2169 case BIGNUM_T: | |
| 2170 bignum_ior (scratch_bignum, XBIGNUM_DATA (result), | |
| 2171 XBIGNUM_DATA (other)); | |
| 2172 result = make_bignum_bg (scratch_bignum); | |
| 2173 break; | |
| 2174 } | |
| 2175 } | |
| 2176 return Fcanonicalize_number (result); | |
| 2177 #else /* !HAVE_BIGNUM */ | |
| 428 | 2178 EMACS_INT bits = 0; |
| 2179 Lisp_Object *args_end = args + nargs; | |
| 2180 | |
| 2181 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
|
2182 bits |= fixnum_char_or_marker_to_int (*args++); |
| 428 | 2183 |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2184 return make_fixnum (bits); |
| 1983 | 2185 #endif /* HAVE_BIGNUM */ |
| 428 | 2186 } |
| 2187 | |
| 2188 DEFUN ("logxor", Flogxor, 0, MANY, 0, /* | |
| 2189 Return bitwise-exclusive-or of all the arguments. | |
| 2190 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
|
2191 |
|
80cd90837ac5
Add argument information to remaining MANY or UNEVALLED C subrs.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3355
diff
changeset
|
2192 arguments: (&rest ARGS) |
| 428 | 2193 */ |
| 2194 (int nargs, Lisp_Object *args)) | |
| 2195 { | |
| 1983 | 2196 #ifdef HAVE_BIGNUM |
| 2197 REGISTER int i; | |
| 2198 Lisp_Object result, other; | |
| 2199 | |
| 2200 if (nargs == 0) | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2201 return make_fixnum (0); |
| 1983 | 2202 |
| 2203 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
|
2204 args[0] = wrong_type_argument (Qinteger_char_or_marker_p, args[0]); |
| 1983 | 2205 |
| 2206 result = args[0]; | |
| 2207 if (CHARP (result)) | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2208 result = make_fixnum (XCHAR (result)); |
| 1983 | 2209 else if (MARKERP (result)) |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2210 result = make_fixnum (marker_position (result)); |
| 1983 | 2211 for (i = 1; i < nargs; i++) |
| 2212 { | |
| 2213 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
|
2214 args[i] = wrong_type_argument (Qinteger_char_or_marker_p, args[i]); |
| 1983 | 2215 other = args[i]; |
| 2216 if (promote_args (&result, &other) == FIXNUM_T) | |
| 2217 { | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2218 result = make_fixnum (XREALFIXNUM (result) ^ XREALFIXNUM (other)); |
| 1983 | 2219 } |
| 2220 else | |
| 2221 { | |
| 2222 bignum_xor (scratch_bignum, XBIGNUM_DATA (result), | |
| 2223 XBIGNUM_DATA (other)); | |
| 2224 result = make_bignum_bg (scratch_bignum); | |
| 2225 } | |
| 2226 } | |
| 2227 return Fcanonicalize_number (result); | |
| 2228 #else /* !HAVE_BIGNUM */ | |
| 428 | 2229 EMACS_INT bits = 0; |
| 2230 Lisp_Object *args_end = args + nargs; | |
| 2231 | |
| 2232 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
|
2233 bits ^= fixnum_char_or_marker_to_int (*args++); |
| 428 | 2234 |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2235 return make_fixnum (bits); |
| 1983 | 2236 #endif /* !HAVE_BIGNUM */ |
| 428 | 2237 } |
| 2238 | |
| 2239 DEFUN ("lognot", Flognot, 1, 1, 0, /* | |
| 2240 Return the bitwise complement of NUMBER. | |
| 2241 NUMBER may be an integer, marker or character converted to integer. | |
| 2242 */ | |
| 2243 (number)) | |
| 2244 { | |
|
4885
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
2245 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
|
2246 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
|
2247 |
| 1983 | 2248 #ifdef HAVE_BIGNUM |
| 2249 if (BIGNUMP (number)) | |
| 2250 { | |
| 2251 bignum_not (scratch_bignum, XBIGNUM_DATA (number)); | |
| 2252 return make_bignum_bg (scratch_bignum); | |
| 2253 } | |
| 2254 #endif /* HAVE_BIGNUM */ | |
|
4885
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
2255 |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2256 return make_fixnum (~ fixnum_char_or_marker_to_int (number)); |
| 428 | 2257 } |
| 2258 | |
| 2259 DEFUN ("%", Frem, 2, 2, 0, /* | |
| 2260 Return remainder of first arg divided by second. | |
| 2261 Both must be integers, characters or markers. | |
| 2262 */ | |
| 444 | 2263 (number1, number2)) |
| 428 | 2264 { |
| 1983 | 2265 #ifdef HAVE_BIGNUM |
| 2266 while (!(CHARP (number1) || MARKERP (number1) || INTEGERP (number1))) | |
| 2267 number1 = wrong_type_argument (Qnumber_char_or_marker_p, number1); | |
| 2268 while (!(CHARP (number2) || MARKERP (number2) || INTEGERP (number2))) | |
| 2269 number2 = wrong_type_argument (Qnumber_char_or_marker_p, number2); | |
| 2270 | |
| 2271 if (promote_args (&number1, &number2) == FIXNUM_T) | |
| 2272 { | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2273 if (XREALFIXNUM (number2) == 0) |
| 1983 | 2274 Fsignal (Qarith_error, Qnil); |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2275 return make_fixnum (XREALFIXNUM (number1) % XREALFIXNUM (number2)); |
| 1983 | 2276 } |
| 2277 else | |
| 2278 { | |
| 2279 if (bignum_sign (XBIGNUM_DATA (number2)) == 0) | |
| 2280 Fsignal (Qarith_error, Qnil); | |
| 2281 bignum_mod (scratch_bignum, XBIGNUM_DATA (number1), | |
| 2282 XBIGNUM_DATA (number2)); | |
| 2283 return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); | |
| 2284 } | |
| 2285 #else /* !HAVE_BIGNUM */ | |
|
4885
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
2286 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
|
2287 EMACS_INT ival2 = fixnum_char_or_marker_to_int (number2); |
| 428 | 2288 |
| 2289 if (ival2 == 0) | |
| 2290 Fsignal (Qarith_error, Qnil); | |
| 2291 | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2292 return make_fixnum (ival1 % ival2); |
| 1983 | 2293 #endif /* HAVE_BIGNUM */ |
| 428 | 2294 } |
| 2295 | |
| 2296 /* Note, ANSI *requires* the presence of the fmod() library routine. | |
| 2297 If your system doesn't have it, complain to your vendor, because | |
| 2298 that is a bug. */ | |
| 2299 | |
| 2300 #ifndef HAVE_FMOD | |
| 2301 double | |
| 2302 fmod (double f1, double f2) | |
| 2303 { | |
| 2304 if (f2 < 0.0) | |
| 2305 f2 = -f2; | |
| 2306 return f1 - f2 * floor (f1/f2); | |
| 2307 } | |
| 2308 #endif /* ! HAVE_FMOD */ | |
| 2309 | |
| 2310 | |
| 2311 DEFUN ("mod", Fmod, 2, 2, 0, /* | |
| 2312 Return X modulo Y. | |
| 2313 The result falls between zero (inclusive) and Y (exclusive). | |
| 2314 Both X and Y must be numbers, characters or markers. | |
| 2315 If either argument is a float, a float will be returned. | |
| 2316 */ | |
| 2317 (x, y)) | |
| 2318 { | |
| 1983 | 2319 #ifdef WITH_NUMBER_TYPES |
| 2320 while (!(CHARP (x) || MARKERP (x) || REALP (x))) | |
| 2321 x = wrong_type_argument (Qnumber_char_or_marker_p, x); | |
| 2322 while (!(CHARP (y) || MARKERP (y) || REALP (y))) | |
| 2323 y = wrong_type_argument (Qnumber_char_or_marker_p, y); | |
| 2324 switch (promote_args (&x, &y)) | |
| 2325 { | |
| 2326 case FIXNUM_T: | |
| 2327 { | |
| 2328 EMACS_INT ival; | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2329 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
|
2330 ival = XREALFIXNUM (x) % XREALFIXNUM (y); |
| 1983 | 2331 /* 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
|
2332 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
|
2333 ival += XREALFIXNUM (y); |
|
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2334 return make_fixnum (ival); |
| 1983 | 2335 } |
| 2336 #ifdef HAVE_BIGNUM | |
| 2337 case BIGNUM_T: | |
| 2338 if (bignum_sign (XBIGNUM_DATA (y)) == 0) goto divide_by_zero; | |
| 2339 bignum_mod (scratch_bignum, XBIGNUM_DATA (x), XBIGNUM_DATA (y)); | |
| 2340 return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); | |
| 2341 #endif | |
| 2342 #ifdef HAVE_RATIO | |
| 2343 case RATIO_T: | |
| 2344 if (ratio_sign (XRATIO_DATA (y)) == 0) goto divide_by_zero; | |
| 2345 ratio_div (scratch_ratio, XRATIO_DATA (x), XRATIO_DATA (y)); | |
| 2346 bignum_div (scratch_bignum, ratio_numerator (scratch_ratio), | |
| 2347 ratio_denominator (scratch_ratio)); | |
| 2348 ratio_set_bignum (scratch_ratio, scratch_bignum); | |
| 2349 ratio_mul (scratch_ratio, scratch_ratio, XRATIO_DATA (y)); | |
| 2350 ratio_sub (scratch_ratio, XRATIO_DATA (x), scratch_ratio); | |
| 2351 return Fcanonicalize_number (make_ratio_rt (scratch_ratio)); | |
| 2352 #endif | |
| 2353 case FLOAT_T: | |
| 2354 { | |
| 2355 double dval; | |
| 2356 if (XFLOAT_DATA (y) == 0.0) goto divide_by_zero; | |
| 2357 dval = fmod (XFLOAT_DATA (x), XFLOAT_DATA (y)); | |
| 2358 /* If the "remainder" comes out with the wrong sign, fix it. */ | |
| 2359 if (XFLOAT_DATA (y) < 0 ? dval > 0 : dval < 0) | |
| 2360 dval += XFLOAT_DATA (y); | |
| 2361 return make_float (dval); | |
| 2362 } | |
| 2363 #ifdef HAVE_BIGFLOAT | |
| 2364 case BIGFLOAT_T: | |
| 2365 bigfloat_set_prec (scratch_bigfloat, | |
| 2366 max (XBIGFLOAT_GET_PREC (x), XBIGFLOAT_GET_PREC (y))); | |
| 2367 bigfloat_div (scratch_bigfloat, XBIGFLOAT_DATA (x), XBIGFLOAT_DATA (y)); | |
| 2368 bigfloat_trunc (scratch_bigfloat, scratch_bigfloat); | |
| 2369 bigfloat_mul (scratch_bigfloat, scratch_bigfloat, XBIGFLOAT_DATA (y)); | |
| 2370 bigfloat_sub (scratch_bigfloat, XBIGFLOAT_DATA (x), scratch_bigfloat); | |
| 2371 return make_bigfloat_bf (scratch_bigfloat); | |
| 2372 #endif | |
| 2373 } | |
| 2374 #else /* !WITH_NUMBER_TYPES */ | |
| 428 | 2375 int_or_double iod1, iod2; |
| 2376 number_char_or_marker_to_int_or_double (x, &iod1); | |
| 2377 number_char_or_marker_to_int_or_double (y, &iod2); | |
| 2378 | |
| 2379 if (!iod1.int_p || !iod2.int_p) | |
| 2380 { | |
| 2381 double dval1 = iod1.int_p ? (double) iod1.c.ival : iod1.c.dval; | |
| 2382 double dval2 = iod2.int_p ? (double) iod2.c.ival : iod2.c.dval; | |
| 2383 if (dval2 == 0) goto divide_by_zero; | |
| 2384 dval1 = fmod (dval1, dval2); | |
| 2385 | |
| 2386 /* If the "remainder" comes out with the wrong sign, fix it. */ | |
| 2387 if (dval2 < 0 ? dval1 > 0 : dval1 < 0) | |
| 2388 dval1 += dval2; | |
| 2389 | |
| 2390 return make_float (dval1); | |
| 2391 } | |
| 1104 | 2392 |
| 428 | 2393 { |
| 2394 EMACS_INT ival; | |
| 2395 if (iod2.c.ival == 0) goto divide_by_zero; | |
| 2396 | |
| 2397 ival = iod1.c.ival % iod2.c.ival; | |
| 2398 | |
| 2399 /* If the "remainder" comes out with the wrong sign, fix it. */ | |
| 2400 if (iod2.c.ival < 0 ? ival > 0 : ival < 0) | |
| 2401 ival += iod2.c.ival; | |
| 2402 | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2403 return make_fixnum (ival); |
| 428 | 2404 } |
| 1983 | 2405 #endif /* WITH_NUMBER_TYPES */ |
| 428 | 2406 |
| 2407 divide_by_zero: | |
| 2408 Fsignal (Qarith_error, Qnil); | |
| 801 | 2409 return Qnil; /* not (usually) reached */ |
| 428 | 2410 } |
| 2411 | |
| 2412 DEFUN ("ash", Fash, 2, 2, 0, /* | |
| 2413 Return VALUE with its bits shifted left by COUNT. | |
| 2414 If COUNT is negative, shifting is actually to the right. | |
| 2415 In this case, the sign bit is duplicated. | |
| 1983 | 2416 This function cannot be applied to bignums, as there is no leftmost sign bit |
| 2417 to be duplicated. Use `lsh' instead. | |
| 428 | 2418 */ |
| 2419 (value, count)) | |
| 2420 { | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2421 CHECK_FIXNUM_COERCE_CHAR (value); |
|
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2422 CONCHECK_FIXNUM (count); |
|
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2423 |
|
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2424 return make_fixnum (XFIXNUM (count) > 0 ? |
|
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2425 XFIXNUM (value) << XFIXNUM (count) : |
|
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2426 XFIXNUM (value) >> -XFIXNUM (count)); |
| 428 | 2427 } |
| 2428 | |
| 2429 DEFUN ("lsh", Flsh, 2, 2, 0, /* | |
| 2430 Return VALUE with its bits shifted left by COUNT. | |
| 2431 If COUNT is negative, shifting is actually to the right. | |
| 2432 In this case, zeros are shifted in on the left. | |
| 2433 */ | |
| 2434 (value, count)) | |
| 2435 { | |
| 1983 | 2436 #ifdef HAVE_BIGNUM |
| 2437 while (!(CHARP (value) || MARKERP (value) || INTEGERP (value))) | |
| 2438 wrong_type_argument (Qnumber_char_or_marker_p, value); | |
| 2439 CONCHECK_INTEGER (count); | |
| 2440 | |
| 2441 if (promote_args (&value, &count) == FIXNUM_T) | |
| 2442 { | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2443 if (XREALFIXNUM (count) <= 0) |
|
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2444 return make_fixnum (XREALFIXNUM (value) >> -XREALFIXNUM (count)); |
| 1983 | 2445 /* Use bignums to avoid overflow */ |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2446 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
|
2447 bignum_lshift (scratch_bignum, scratch_bignum2, XREALFIXNUM (count)); |
| 1983 | 2448 return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); |
| 2449 } | |
| 2450 else | |
| 2451 { | |
| 2452 if (bignum_sign (XBIGNUM_DATA (count)) <= 0) | |
| 2453 { | |
| 2454 bignum_neg (scratch_bignum, XBIGNUM_DATA (count)); | |
| 2455 if (!bignum_fits_ulong_p (scratch_bignum)) | |
| 2456 args_out_of_range (Qnumber_char_or_marker_p, count); | |
| 2457 bignum_rshift (scratch_bignum2, XBIGNUM_DATA (value), | |
| 2458 bignum_to_ulong (scratch_bignum)); | |
| 2459 } | |
| 2460 else | |
| 2461 { | |
| 2462 if (!bignum_fits_ulong_p (XBIGNUM_DATA (count))) | |
| 2463 args_out_of_range (Qnumber_char_or_marker_p, count); | |
| 2464 bignum_lshift (scratch_bignum2, XBIGNUM_DATA (value), | |
| 2465 bignum_to_ulong (XBIGNUM_DATA (count))); | |
| 2466 } | |
| 2467 return Fcanonicalize_number (make_bignum_bg (scratch_bignum2)); | |
| 2468 } | |
| 2469 #else /* !HAVE_BIGNUM */ | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2470 CHECK_FIXNUM_COERCE_CHAR (value); |
|
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2471 CONCHECK_FIXNUM (count); |
|
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2472 |
|
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2473 return make_fixnum (XFIXNUM (count) > 0 ? |
|
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2474 XUINT (value) << XFIXNUM (count) : |
|
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2475 XUINT (value) >> -XFIXNUM (count)); |
| 1983 | 2476 #endif /* HAVE_BIGNUM */ |
| 428 | 2477 } |
| 2478 | |
| 2479 DEFUN ("1+", Fadd1, 1, 1, 0, /* | |
| 2480 Return NUMBER plus one. NUMBER may be a number, character or marker. | |
| 2481 Markers and characters are converted to integers. | |
| 2482 */ | |
| 2483 (number)) | |
| 2484 { | |
| 2485 retry: | |
| 2486 | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2487 if (FIXNUMP (number)) return make_integer (XFIXNUM (number) + 1); |
|
5762
427a72c6ee17
Eliminate several compiler (clang) warnings.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
5752
diff
changeset
|
2488 if (CHARP (number)) return make_integer ((EMACS_INT) XCHAR (number) + 1); |
| 1983 | 2489 if (MARKERP (number)) return make_integer (marker_position (number) + 1); |
| 428 | 2490 if (FLOATP (number)) return make_float (XFLOAT_DATA (number) + 1.0); |
| 1983 | 2491 #ifdef HAVE_BIGNUM |
| 2492 if (BIGNUMP (number)) | |
| 2493 { | |
| 2494 bignum_set_long (scratch_bignum, 1L); | |
| 2495 bignum_add (scratch_bignum2, XBIGNUM_DATA (number), scratch_bignum); | |
| 2496 return Fcanonicalize_number (make_bignum_bg (scratch_bignum2)); | |
| 2497 } | |
| 2498 #endif | |
| 2499 #ifdef HAVE_RATIO | |
| 2500 if (RATIOP (number)) | |
| 2501 { | |
| 2502 ratio_set_long (scratch_ratio, 1L); | |
| 2503 ratio_add (scratch_ratio, XRATIO_DATA (number), scratch_ratio); | |
| 2504 /* No need to canonicalize after adding 1 */ | |
| 2505 return make_ratio_rt (scratch_ratio); | |
| 2506 } | |
| 2507 #endif | |
| 2508 #ifdef HAVE_BIGFLOAT | |
| 2509 if (BIGFLOATP (number)) | |
| 2510 { | |
| 2511 bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number)); | |
| 2512 bigfloat_set_long (scratch_bigfloat, 1L); | |
| 2513 bigfloat_add (scratch_bigfloat, XBIGFLOAT_DATA (number), | |
| 2514 scratch_bigfloat); | |
| 2515 return make_bigfloat_bf (scratch_bigfloat); | |
| 2516 } | |
| 2517 #endif | |
| 428 | 2518 |
| 2519 number = wrong_type_argument (Qnumber_char_or_marker_p, number); | |
| 2520 goto retry; | |
| 2521 } | |
| 2522 | |
| 2523 DEFUN ("1-", Fsub1, 1, 1, 0, /* | |
| 2524 Return NUMBER minus one. NUMBER may be a number, character or marker. | |
| 2525 Markers and characters are converted to integers. | |
| 2526 */ | |
| 2527 (number)) | |
| 2528 { | |
| 2529 retry: | |
| 2530 | |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
2531 if (FIXNUMP (number)) return make_integer (XFIXNUM (number) - 1); |
|
5762
427a72c6ee17
Eliminate several compiler (clang) warnings.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
5752
diff
changeset
|
2532 if (CHARP (number)) return make_integer ((EMACS_INT) XCHAR (number) - 1); |
| 1983 | 2533 if (MARKERP (number)) return make_integer (marker_position (number) - 1); |
| 428 | 2534 if (FLOATP (number)) return make_float (XFLOAT_DATA (number) - 1.0); |
| 1983 | 2535 #ifdef HAVE_BIGNUM |
| 2536 if (BIGNUMP (number)) | |
| 2537 { | |
| 2538 bignum_set_long (scratch_bignum, 1L); | |
| 2539 bignum_sub (scratch_bignum2, XBIGNUM_DATA (number), scratch_bignum); | |
| 2540 return Fcanonicalize_number (make_bignum_bg (scratch_bignum2)); | |
| 2541 } | |
| 2542 #endif | |
| 2543 #ifdef HAVE_RATIO | |
| 2544 if (RATIOP (number)) | |
| 2545 { | |
| 2546 ratio_set_long (scratch_ratio, 1L); | |
| 2547 ratio_sub (scratch_ratio, XRATIO_DATA (number), scratch_ratio); | |
| 2548 /* No need to canonicalize after subtracting 1 */ | |
| 2549 return make_ratio_rt (scratch_ratio); | |
| 2550 } | |
| 2551 #endif | |
| 2552 #ifdef HAVE_BIGFLOAT | |
| 2553 if (BIGFLOATP (number)) | |
| 2554 { | |
| 2555 bigfloat_set_prec (scratch_bigfloat, XBIGFLOAT_GET_PREC (number)); | |
| 2556 bigfloat_set_long (scratch_bigfloat, 1L); | |
| 2557 bigfloat_sub (scratch_bigfloat, XBIGFLOAT_DATA (number), | |
| 2558 scratch_bigfloat); | |
| 2559 return make_bigfloat_bf (scratch_bigfloat); | |
| 2560 } | |
| 2561 #endif | |
| 428 | 2562 |
| 2563 number = wrong_type_argument (Qnumber_char_or_marker_p, number); | |
| 2564 goto retry; | |
| 2565 } | |
| 2566 | |
| 2567 | |
| 2568 /************************************************************************/ | |
| 2569 /* weak lists */ | |
| 2570 /************************************************************************/ | |
| 2571 | |
| 2572 /* A weak list is like a normal list except that elements automatically | |
| 2573 disappear when no longer in use, i.e. when no longer GC-protected. | |
| 2574 The basic idea is that we don't mark the elements during GC, but | |
| 2575 wait for them to be marked elsewhere. If they're not marked, we | |
| 2576 remove them. This is analogous to weak hash tables; see the explanation | |
| 2577 there for more info. */ | |
| 2578 | |
| 2579 static Lisp_Object Vall_weak_lists; /* Gemarke es nicht!!! */ | |
| 2580 | |
| 2581 static Lisp_Object encode_weak_list_type (enum weak_list_type type); | |
| 2582 | |
| 2583 static Lisp_Object | |
| 2286 | 2584 mark_weak_list (Lisp_Object UNUSED (obj)) |
| 428 | 2585 { |
| 2586 return Qnil; /* nichts ist gemarkt */ | |
| 2587 } | |
| 2588 | |
| 2589 static void | |
| 2286 | 2590 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
|
2591 int escapeflag) |
| 428 | 2592 { |
| 2593 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
|
2594 { |
|
47298dcf2e8f
Be more helpful in printing ephemerons, weak lists, and weak boxes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5307
diff
changeset
|
2595 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
|
2596 } |
|
47298dcf2e8f
Be more helpful in printing ephemerons, weak lists, and weak boxes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5307
diff
changeset
|
2597 |
|
47298dcf2e8f
Be more helpful in printing ephemerons, weak lists, and weak boxes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5307
diff
changeset
|
2598 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
|
2599 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
|
2600 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_ascstring (printcharfun, " :list "); |
|
47298dcf2e8f
Be more helpful in printing ephemerons, weak lists, and weak boxes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5307
diff
changeset
|
2602 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
|
2603 write_fmt_string (printcharfun, " 0x%x>", LISP_OBJECT_UID (obj)); |
| 428 | 2604 } |
| 2605 | |
| 2606 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
|
2607 weak_list_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, int foldcase) |
| 428 | 2608 { |
| 2609 struct weak_list *w1 = XWEAK_LIST (obj1); | |
| 2610 struct weak_list *w2 = XWEAK_LIST (obj2); | |
| 2611 | |
| 2612 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
|
2613 internal_equal_0 (w1->list, w2->list, depth + 1, foldcase)); |
| 428 | 2614 } |
| 2615 | |
| 665 | 2616 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
|
2617 weak_list_hash (Lisp_Object obj, int depth, Boolint equalp) |
| 428 | 2618 { |
| 2619 struct weak_list *w = XWEAK_LIST (obj); | |
| 2620 | |
| 665 | 2621 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
|
2622 internal_hash (w->list, depth + 1, equalp)); |
| 428 | 2623 } |
| 2624 | |
| 2625 Lisp_Object | |
| 2626 make_weak_list (enum weak_list_type type) | |
| 2627 { | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
2628 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
|
2629 struct weak_list *wl = XWEAK_LIST (result); |
| 428 | 2630 |
| 2631 wl->list = Qnil; | |
| 2632 wl->type = type; | |
| 2633 wl->next_weak = Vall_weak_lists; | |
| 2634 Vall_weak_lists = result; | |
| 2635 return result; | |
| 2636 } | |
| 2637 | |
| 1204 | 2638 static const struct memory_description weak_list_description[] = { |
| 1598 | 2639 { XD_LISP_OBJECT, offsetof (struct weak_list, list), |
| 2551 | 2640 0, { 0 }, XD_FLAG_NO_KKCC }, |
| 1598 | 2641 { XD_LO_LINK, offsetof (struct weak_list, next_weak), |
| 2551 | 2642 0, { 0 }, XD_FLAG_NO_KKCC }, |
| 428 | 2643 { XD_END } |
| 2644 }; | |
| 2645 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
2646 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
|
2647 mark_weak_list, print_weak_list, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
2648 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
|
2649 weak_list_description, |
|
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
2650 struct weak_list); |
| 428 | 2651 /* |
| 2652 -- we do not mark the list elements (either the elements themselves | |
| 2653 or the cons cells that hold them) in the normal marking phase. | |
| 2654 -- at the end of marking, we go through all weak lists that are | |
| 2655 marked, and mark the cons cells that hold all marked | |
| 2656 objects, and possibly parts of the objects themselves. | |
| 2657 (See alloc.c, "after-mark".) | |
| 2658 -- after that, we prune away all the cons cells that are not marked. | |
| 2659 | |
| 2660 WARNING WARNING WARNING WARNING WARNING: | |
| 2661 | |
| 2662 The code in the following two functions is *unbelievably* tricky. | |
| 2663 Don't mess with it. You'll be sorry. | |
| 2664 | |
| 2665 Linked lists just majorly suck, d'ya know? | |
| 2666 */ | |
| 2667 | |
| 2668 int | |
| 2669 finish_marking_weak_lists (void) | |
| 2670 { | |
| 2671 Lisp_Object rest; | |
| 2672 int did_mark = 0; | |
| 2673 | |
| 2674 for (rest = Vall_weak_lists; | |
| 2675 !NILP (rest); | |
| 2676 rest = XWEAK_LIST (rest)->next_weak) | |
| 2677 { | |
| 2678 Lisp_Object rest2; | |
| 2679 enum weak_list_type type = XWEAK_LIST (rest)->type; | |
| 2680 | |
| 2681 if (! marked_p (rest)) | |
| 2682 /* The weak list is probably garbage. Ignore it. */ | |
| 2683 continue; | |
| 2684 | |
| 2685 for (rest2 = XWEAK_LIST (rest)->list; | |
| 2686 /* We need to be trickier since we're inside of GC; | |
| 2687 use CONSP instead of !NILP in case of user-visible | |
| 2688 imperfect lists */ | |
| 2689 CONSP (rest2); | |
| 2690 rest2 = XCDR (rest2)) | |
| 2691 { | |
| 2692 Lisp_Object elem; | |
| 2693 /* If the element is "marked" (meaning depends on the type | |
| 2694 of weak list), we need to mark the cons containing the | |
| 2695 element, and maybe the element itself (if only some part | |
| 2696 was already marked). */ | |
| 2697 int need_to_mark_cons = 0; | |
| 2698 int need_to_mark_elem = 0; | |
| 2699 | |
| 2700 /* If a cons is already marked, then its car is already marked | |
| 2701 (either because of an external pointer or because of | |
| 2702 a previous call to this function), and likewise for all | |
| 2703 the rest of the elements in the list, so we can stop now. */ | |
| 2704 if (marked_p (rest2)) | |
| 2705 break; | |
| 2706 | |
| 2707 elem = XCAR (rest2); | |
| 2708 | |
| 2709 switch (type) | |
| 2710 { | |
| 2711 case WEAK_LIST_SIMPLE: | |
| 2712 if (marked_p (elem)) | |
| 2713 need_to_mark_cons = 1; | |
| 2714 break; | |
| 2715 | |
| 2716 case WEAK_LIST_ASSOC: | |
| 2717 if (!CONSP (elem)) | |
| 2718 { | |
| 2719 /* just leave bogus elements there */ | |
| 2720 need_to_mark_cons = 1; | |
| 2721 need_to_mark_elem = 1; | |
| 2722 } | |
| 2723 else if (marked_p (XCAR (elem)) && | |
| 2724 marked_p (XCDR (elem))) | |
| 2725 { | |
| 2726 need_to_mark_cons = 1; | |
| 2727 /* We still need to mark elem, because it's | |
| 2728 probably not marked. */ | |
| 2729 need_to_mark_elem = 1; | |
| 2730 } | |
| 2731 break; | |
| 2732 | |
| 2733 case WEAK_LIST_KEY_ASSOC: | |
| 2734 if (!CONSP (elem)) | |
| 2735 { | |
| 2736 /* just leave bogus elements there */ | |
| 2737 need_to_mark_cons = 1; | |
| 2738 need_to_mark_elem = 1; | |
| 2739 } | |
| 2740 else if (marked_p (XCAR (elem))) | |
| 2741 { | |
| 2742 need_to_mark_cons = 1; | |
| 2743 /* We still need to mark elem and XCDR (elem); | |
| 2744 marking elem does both */ | |
| 2745 need_to_mark_elem = 1; | |
| 2746 } | |
| 2747 break; | |
| 2748 | |
| 2749 case WEAK_LIST_VALUE_ASSOC: | |
| 2750 if (!CONSP (elem)) | |
| 2751 { | |
| 2752 /* just leave bogus elements there */ | |
| 2753 need_to_mark_cons = 1; | |
| 2754 need_to_mark_elem = 1; | |
| 2755 } | |
| 2756 else if (marked_p (XCDR (elem))) | |
| 2757 { | |
| 2758 need_to_mark_cons = 1; | |
| 2759 /* We still need to mark elem and XCAR (elem); | |
| 2760 marking elem does both */ | |
| 2761 need_to_mark_elem = 1; | |
| 2762 } | |
| 2763 break; | |
| 2764 | |
| 442 | 2765 case WEAK_LIST_FULL_ASSOC: |
| 2766 if (!CONSP (elem)) | |
| 2767 { | |
| 2768 /* just leave bogus elements there */ | |
| 2769 need_to_mark_cons = 1; | |
| 2770 need_to_mark_elem = 1; | |
| 2771 } | |
| 2772 else if (marked_p (XCAR (elem)) || | |
| 2773 marked_p (XCDR (elem))) | |
| 2774 { | |
| 2775 need_to_mark_cons = 1; | |
| 2776 /* We still need to mark elem and XCAR (elem); | |
| 2777 marking elem does both */ | |
| 2778 need_to_mark_elem = 1; | |
| 2779 } | |
| 2780 break; | |
| 2781 | |
| 428 | 2782 default: |
| 2500 | 2783 ABORT (); |
| 428 | 2784 } |
| 2785 | |
| 2786 if (need_to_mark_elem && ! marked_p (elem)) | |
| 2787 { | |
| 1598 | 2788 #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
|
2789 kkcc_gc_stack_push_lisp_object_0 (elem); |
| 1598 | 2790 #else /* NOT USE_KKCC */ |
| 428 | 2791 mark_object (elem); |
| 1598 | 2792 #endif /* NOT USE_KKCC */ |
| 428 | 2793 did_mark = 1; |
| 2794 } | |
| 2795 | |
| 2796 /* We also need to mark the cons that holds the elem or | |
| 2797 assoc-pair. We do *not* want to call (mark_object) here | |
| 2798 because that will mark the entire list; we just want to | |
| 2799 mark the cons itself. | |
| 2800 */ | |
| 2801 if (need_to_mark_cons) | |
| 2802 { | |
| 2803 Lisp_Cons *c = XCONS (rest2); | |
| 2804 if (!CONS_MARKED_P (c)) | |
| 2805 { | |
| 2806 MARK_CONS (c); | |
| 2807 did_mark = 1; | |
| 2808 } | |
| 2809 } | |
| 2810 } | |
| 2811 | |
| 2812 /* In case of imperfect list, need to mark the final cons | |
| 2813 because we're not removing it */ | |
| 2814 if (!NILP (rest2) && ! marked_p (rest2)) | |
| 2815 { | |
| 1598 | 2816 #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
|
2817 kkcc_gc_stack_push_lisp_object_0 (rest2); |
| 1598 | 2818 #else /* NOT USE_KKCC */ |
| 428 | 2819 mark_object (rest2); |
| 1598 | 2820 #endif /* NOT USE_KKCC */ |
| 428 | 2821 did_mark = 1; |
| 2822 } | |
| 2823 } | |
| 2824 | |
| 2825 return did_mark; | |
| 2826 } | |
| 2827 | |
| 2828 void | |
| 2829 prune_weak_lists (void) | |
| 2830 { | |
| 2831 Lisp_Object rest, prev = Qnil; | |
| 2832 | |
| 2833 for (rest = Vall_weak_lists; | |
| 2834 !NILP (rest); | |
| 2835 rest = XWEAK_LIST (rest)->next_weak) | |
| 2836 { | |
| 2837 if (! (marked_p (rest))) | |
| 2838 { | |
| 2839 /* This weak list itself is garbage. Remove it from the list. */ | |
| 2840 if (NILP (prev)) | |
| 2841 Vall_weak_lists = XWEAK_LIST (rest)->next_weak; | |
| 2842 else | |
| 2843 XWEAK_LIST (prev)->next_weak = | |
| 2844 XWEAK_LIST (rest)->next_weak; | |
| 2845 } | |
| 2846 else | |
| 2847 { | |
| 2848 Lisp_Object rest2, prev2 = Qnil; | |
| 2849 Lisp_Object tortoise; | |
| 2850 int go_tortoise = 0; | |
| 2851 | |
| 2852 for (rest2 = XWEAK_LIST (rest)->list, tortoise = rest2; | |
| 2853 /* We need to be trickier since we're inside of GC; | |
| 2854 use CONSP instead of !NILP in case of user-visible | |
| 2855 imperfect lists */ | |
| 2856 CONSP (rest2);) | |
| 2857 { | |
| 2858 /* It suffices to check the cons for marking, | |
| 2859 regardless of the type of weak list: | |
| 2860 | |
| 2861 -- if the cons is pointed to somewhere else, | |
| 2862 then it should stay around and will be marked. | |
| 2863 -- otherwise, if it should stay around, it will | |
| 2864 have been marked in finish_marking_weak_lists(). | |
| 2865 -- otherwise, it's not marked and should disappear. | |
| 2866 */ | |
| 2867 if (! marked_p (rest2)) | |
| 2868 { | |
| 2869 /* bye bye :-( */ | |
| 2870 if (NILP (prev2)) | |
| 2871 XWEAK_LIST (rest)->list = XCDR (rest2); | |
| 2872 else | |
| 2873 XCDR (prev2) = XCDR (rest2); | |
| 2874 rest2 = XCDR (rest2); | |
| 2875 /* Ouch. Circularity checking is even trickier | |
| 2876 than I thought. When we cut out a link | |
| 2877 like this, we can't advance the turtle or | |
| 2878 it'll catch up to us. Imagine that we're | |
| 2879 standing on floor tiles and moving forward -- | |
| 2880 what we just did here is as if the floor | |
| 2881 tile under us just disappeared and all the | |
| 2882 ones ahead of us slid one tile towards us. | |
| 2883 In other words, we didn't move at all; | |
| 2884 if the tortoise was one step behind us | |
| 2885 previously, it still is, and therefore | |
| 2886 it must not move. */ | |
| 2887 } | |
| 2888 else | |
| 2889 { | |
| 2890 prev2 = rest2; | |
| 2891 | |
| 2892 /* Implementing circularity checking is trickier here | |
| 2893 than in other places because we have to guarantee | |
| 2894 that we've processed all elements before exiting | |
| 2895 due to a circularity. (In most places, an error | |
| 2896 is issued upon encountering a circularity, so it | |
| 2897 doesn't really matter if all elements are processed.) | |
| 2898 The idea is that we process along with the hare | |
| 2899 rather than the tortoise. If at any point in | |
| 2900 our forward process we encounter the tortoise, | |
| 2901 we must have already visited the spot, so we exit. | |
| 2902 (If we process with the tortoise, we can fail to | |
| 2903 process cases where a cons points to itself, or | |
| 2904 where cons A points to cons B, which points to | |
| 2905 cons A.) */ | |
| 2906 | |
| 2907 rest2 = XCDR (rest2); | |
| 2908 if (go_tortoise) | |
| 2909 tortoise = XCDR (tortoise); | |
| 2910 go_tortoise = !go_tortoise; | |
| 2911 if (EQ (rest2, tortoise)) | |
| 2912 break; | |
| 2913 } | |
| 2914 } | |
| 2915 | |
| 2916 prev = rest; | |
| 2917 } | |
| 2918 } | |
| 2919 } | |
| 2920 | |
| 2921 static enum weak_list_type | |
| 2922 decode_weak_list_type (Lisp_Object symbol) | |
| 2923 { | |
| 2924 CHECK_SYMBOL (symbol); | |
| 2925 if (EQ (symbol, Qsimple)) return WEAK_LIST_SIMPLE; | |
| 2926 if (EQ (symbol, Qassoc)) return WEAK_LIST_ASSOC; | |
| 2927 if (EQ (symbol, Qold_assoc)) return WEAK_LIST_ASSOC; /* EBOLA ALERT! */ | |
| 2928 if (EQ (symbol, Qkey_assoc)) return WEAK_LIST_KEY_ASSOC; | |
| 2929 if (EQ (symbol, Qvalue_assoc)) return WEAK_LIST_VALUE_ASSOC; | |
| 442 | 2930 if (EQ (symbol, Qfull_assoc)) return WEAK_LIST_FULL_ASSOC; |
| 428 | 2931 |
| 563 | 2932 invalid_constant ("Invalid weak list type", symbol); |
| 1204 | 2933 RETURN_NOT_REACHED (WEAK_LIST_SIMPLE); |
| 428 | 2934 } |
| 2935 | |
| 2936 static Lisp_Object | |
| 2937 encode_weak_list_type (enum weak_list_type type) | |
| 2938 { | |
| 2939 switch (type) | |
| 2940 { | |
| 2941 case WEAK_LIST_SIMPLE: return Qsimple; | |
| 2942 case WEAK_LIST_ASSOC: return Qassoc; | |
| 2943 case WEAK_LIST_KEY_ASSOC: return Qkey_assoc; | |
| 2944 case WEAK_LIST_VALUE_ASSOC: return Qvalue_assoc; | |
| 442 | 2945 case WEAK_LIST_FULL_ASSOC: return Qfull_assoc; |
| 428 | 2946 default: |
| 2500 | 2947 ABORT (); |
| 428 | 2948 } |
| 2949 | |
| 801 | 2950 return Qnil; /* not (usually) reached */ |
| 428 | 2951 } |
| 2952 | |
| 2953 DEFUN ("weak-list-p", Fweak_list_p, 1, 1, 0, /* | |
| 2954 Return non-nil if OBJECT is a weak list. | |
| 2955 */ | |
| 2956 (object)) | |
| 2957 { | |
| 2958 return WEAK_LISTP (object) ? Qt : Qnil; | |
| 2959 } | |
| 2960 | |
| 2961 DEFUN ("make-weak-list", Fmake_weak_list, 0, 1, 0, /* | |
| 2962 Return a new weak list object of type TYPE. | |
| 2963 A weak list object is an object that contains a list. This list behaves | |
| 2964 like any other list except that its elements do not count towards | |
| 456 | 2965 garbage collection -- if the only pointer to an object is inside a weak |
| 428 | 2966 list (other than pointers in similar objects such as weak hash tables), |
| 2967 the object is garbage collected and automatically removed from the list. | |
| 2968 This is used internally, for example, to manage the list holding the | |
| 2969 children of an extent -- an extent that is unused but has a parent will | |
| 2970 still be reclaimed, and will automatically be removed from its parent's | |
| 2971 list of children. | |
| 2972 | |
| 2973 Optional argument TYPE specifies the type of the weak list, and defaults | |
| 2974 to `simple'. Recognized types are | |
| 2975 | |
| 2976 `simple' Objects in the list disappear if not pointed to. | |
| 2977 `assoc' Objects in the list disappear if they are conses | |
| 2978 and either the car or the cdr of the cons is not | |
| 2979 pointed to. | |
| 2980 `key-assoc' Objects in the list disappear if they are conses | |
| 2981 and the car is not pointed to. | |
| 2982 `value-assoc' Objects in the list disappear if they are conses | |
| 2983 and the cdr is not pointed to. | |
| 442 | 2984 `full-assoc' Objects in the list disappear if they are conses |
| 2985 and neither the car nor the cdr is pointed to. | |
| 428 | 2986 */ |
| 2987 (type)) | |
| 2988 { | |
| 2989 if (NILP (type)) | |
| 2990 type = Qsimple; | |
| 2991 | |
| 2992 return make_weak_list (decode_weak_list_type (type)); | |
| 2993 } | |
| 2994 | |
| 2995 DEFUN ("weak-list-type", Fweak_list_type, 1, 1, 0, /* | |
| 2996 Return the type of the given weak-list object. | |
| 2997 */ | |
| 2998 (weak)) | |
| 2999 { | |
| 3000 CHECK_WEAK_LIST (weak); | |
| 3001 return encode_weak_list_type (XWEAK_LIST (weak)->type); | |
| 3002 } | |
| 3003 | |
| 3004 DEFUN ("weak-list-list", Fweak_list_list, 1, 1, 0, /* | |
| 3005 Return the list contained in a weak-list object. | |
| 3006 */ | |
| 3007 (weak)) | |
| 3008 { | |
| 3009 CHECK_WEAK_LIST (weak); | |
| 3010 return XWEAK_LIST_LIST (weak); | |
| 3011 } | |
| 3012 | |
| 3013 DEFUN ("set-weak-list-list", Fset_weak_list_list, 2, 2, 0, /* | |
| 3014 Change the list contained in a weak-list object. | |
| 3015 */ | |
| 3016 (weak, new_list)) | |
| 3017 { | |
| 3018 CHECK_WEAK_LIST (weak); | |
| 3019 XWEAK_LIST_LIST (weak) = new_list; | |
| 3020 return new_list; | |
| 3021 } | |
| 3022 | |
| 888 | 3023 |
| 858 | 3024 /************************************************************************/ |
| 3025 /* weak boxes */ | |
| 3026 /************************************************************************/ | |
| 3027 | |
| 3028 static Lisp_Object Vall_weak_boxes; /* Gemarke es niemals ever!!! */ | |
| 3029 | |
| 3030 void | |
| 3031 prune_weak_boxes (void) | |
| 3032 { | |
| 3033 Lisp_Object rest, prev = Qnil; | |
| 888 | 3034 int removep = 0; |
| 858 | 3035 |
| 3036 for (rest = Vall_weak_boxes; | |
| 3037 !NILP(rest); | |
| 3038 rest = XWEAK_BOX (rest)->next_weak_box) | |
| 3039 { | |
| 3040 if (! (marked_p (rest))) | |
| 888 | 3041 /* This weak box itself is garbage. */ |
| 3042 removep = 1; | |
| 3043 | |
| 3044 if (! marked_p (XWEAK_BOX (rest)->value)) | |
| 3045 { | |
| 3046 XSET_WEAK_BOX (rest, Qnil); | |
| 3047 removep = 1; | |
| 3048 } | |
| 3049 | |
| 3050 if (removep) | |
| 3051 { | |
| 3052 /* Remove weak box from list. */ | |
| 3053 if (NILP (prev)) | |
| 3054 Vall_weak_boxes = XWEAK_BOX (rest)->next_weak_box; | |
| 3055 else | |
| 3056 XWEAK_BOX (prev)->next_weak_box = XWEAK_BOX (rest)->next_weak_box; | |
| 3057 removep = 0; | |
| 3058 } | |
| 3059 else | |
| 3060 prev = rest; | |
| 858 | 3061 } |
| 3062 } | |
| 3063 | |
| 3064 static Lisp_Object | |
| 2286 | 3065 mark_weak_box (Lisp_Object UNUSED (obj)) |
| 858 | 3066 { |
| 3067 return Qnil; | |
| 3068 } | |
| 3069 | |
| 3070 static void | |
|
5325
47298dcf2e8f
Be more helpful in printing ephemerons, weak lists, and weak boxes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5307
diff
changeset
|
3071 print_weak_box (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) |
| 858 | 3072 { |
| 3073 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
|
3074 { |
|
47298dcf2e8f
Be more helpful in printing ephemerons, weak lists, and weak boxes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5307
diff
changeset
|
3075 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
|
3076 } |
|
47298dcf2e8f
Be more helpful in printing ephemerons, weak lists, and weak boxes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5307
diff
changeset
|
3077 |
|
47298dcf2e8f
Be more helpful in printing ephemerons, weak lists, and weak boxes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5307
diff
changeset
|
3078 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
|
3079 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
|
3080 write_fmt_string (printcharfun, " 0x%x>", LISP_OBJECT_UID (obj)); |
| 858 | 3081 } |
| 3082 | |
| 3083 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
|
3084 weak_box_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, int foldcase) |
| 858 | 3085 { |
| 888 | 3086 struct weak_box *wb1 = XWEAK_BOX (obj1); |
| 3087 struct weak_box *wb2 = XWEAK_BOX (obj2); | |
| 858 | 3088 |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4885
diff
changeset
|
3089 return (internal_equal_0 (wb1->value, wb2->value, depth + 1, foldcase)); |
| 858 | 3090 } |
| 3091 | |
| 3092 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
|
3093 weak_box_hash (Lisp_Object obj, int depth, Boolint equalp) |
| 858 | 3094 { |
| 888 | 3095 struct weak_box *wb = XWEAK_BOX (obj); |
| 858 | 3096 |
|
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
|
3097 return internal_hash (wb->value, depth + 1, equalp); |
| 858 | 3098 } |
| 3099 | |
| 3100 Lisp_Object | |
| 3101 make_weak_box (Lisp_Object value) | |
| 3102 { | |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
3103 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
|
3104 struct weak_box *wb = XWEAK_BOX (result); |
| 858 | 3105 |
| 3106 wb->value = value; | |
| 3107 result = wrap_weak_box (wb); | |
| 3108 wb->next_weak_box = Vall_weak_boxes; | |
| 3109 Vall_weak_boxes = result; | |
| 3110 return result; | |
| 3111 } | |
| 3112 | |
| 1204 | 3113 static const struct memory_description weak_box_description[] = { |
| 858 | 3114 { XD_LO_LINK, offsetof (struct weak_box, value) }, |
| 888 | 3115 { XD_END} |
| 858 | 3116 }; |
| 3117 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
3118 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
|
3119 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
|
3120 weak_box_hash, weak_box_description, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
3121 struct weak_box); |
| 858 | 3122 |
| 3123 DEFUN ("make-weak-box", Fmake_weak_box, 1, 1, 0, /* | |
| 3124 Return a new weak box from value CONTENTS. | |
| 3125 The weak box is a reference to CONTENTS which may be extracted with | |
| 3126 `weak-box-ref'. However, the weak box does not contribute to the | |
| 3127 reachability of CONTENTS. When CONTENTS is garbage-collected, | |
| 3128 `weak-box-ref' will return NIL. | |
| 3129 */ | |
| 3130 (value)) | |
| 3131 { | |
|
5752
70a3f4ff8da8
Improve coding style, variable names, data.c, sequence.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5736
diff
changeset
|
3132 return make_weak_box (value); |
| 858 | 3133 } |
| 3134 | |
| 3135 DEFUN ("weak-box-ref", Fweak_box_ref, 1, 1, 0, /* | |
| 3136 Return the contents of weak box WEAK-BOX. | |
| 3137 If the contents have been GCed, return NIL. | |
| 3138 */ | |
|
5752
70a3f4ff8da8
Improve coding style, variable names, data.c, sequence.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5736
diff
changeset
|
3139 (weak_box)) |
| 858 | 3140 { |
|
5752
70a3f4ff8da8
Improve coding style, variable names, data.c, sequence.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5736
diff
changeset
|
3141 return XWEAK_BOX (weak_box)->value; |
| 858 | 3142 } |
| 3143 | |
| 3144 DEFUN ("weak-box-p", Fweak_boxp, 1, 1, 0, /* | |
| 3145 Return non-nil if OBJECT is a weak box. | |
| 3146 */ | |
| 3147 (object)) | |
| 3148 { | |
| 3149 return WEAK_BOXP (object) ? Qt : Qnil; | |
| 3150 } | |
| 3151 | |
| 888 | 3152 /************************************************************************/ |
| 3153 /* ephemerons */ | |
| 3154 /************************************************************************/ | |
| 3155 | |
| 993 | 3156 /* The concept of ephemerons is due to: |
| 3157 * Barry Hayes: Ephemerons: A New Finalization Mechanism. OOPSLA 1997: 176-183 | |
| 3158 * The original idea is due to George Bosworth of Digitalk, Inc. | |
| 3159 * | |
| 3160 * For a discussion of finalization and weakness that also reviews | |
| 3161 * ephemerons, refer to: | |
| 3162 * Simon Peyton Jones, Simon Marlow, Conal Elliot: | |
| 3163 * Stretching the storage manager | |
| 3164 * Implementation of Functional Languages, 1999 | |
| 3165 */ | |
| 3166 | |
| 888 | 3167 static Lisp_Object Vall_ephemerons; /* Gemarke es niemals ever!!! */ |
| 1590 | 3168 static Lisp_Object Vnew_all_ephemerons; |
| 888 | 3169 static Lisp_Object Vfinalize_list; |
| 3170 | |
| 1590 | 3171 void |
|
5752
70a3f4ff8da8
Improve coding style, variable names, data.c, sequence.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5736
diff
changeset
|
3172 init_marking_ephemerons (void) |
| 1590 | 3173 { |
| 3174 Vnew_all_ephemerons = Qnil; | |
| 3175 } | |
| 3176 | |
| 3177 /* Move all live ephemerons with live keys over to | |
| 3178 * Vnew_all_ephemerons, marking the values and finalizers along the | |
| 3179 * way. */ | |
| 3180 | |
| 3181 int | |
|
5752
70a3f4ff8da8
Improve coding style, variable names, data.c, sequence.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5736
diff
changeset
|
3182 continue_marking_ephemerons (void) |
| 1590 | 3183 { |
| 3184 Lisp_Object rest = Vall_ephemerons, next, prev = Qnil; | |
| 3185 int did_mark = 0; | |
| 3186 | |
| 3187 while (!NILP (rest)) | |
| 3188 { | |
| 3189 next = XEPHEMERON_NEXT (rest); | |
| 3190 | |
| 3191 if (marked_p (rest)) | |
| 3192 { | |
| 3193 MARK_CONS (XCONS (XEPHEMERON (rest)->cons_chain)); | |
| 3194 if (marked_p (XEPHEMERON (rest)->key)) | |
| 3195 { | |
| 1598 | 3196 #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
|
3197 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
|
3198 (XCAR (XEPHEMERON (rest)->cons_chain)); |
| 1598 | 3199 #else /* NOT USE_KKCC */ |
| 1590 | 3200 mark_object (XCAR (XEPHEMERON (rest)->cons_chain)); |
| 1598 | 3201 #endif /* NOT USE_KKCC */ |
| 1590 | 3202 did_mark = 1; |
| 3203 XSET_EPHEMERON_NEXT (rest, Vnew_all_ephemerons); | |
| 3204 Vnew_all_ephemerons = rest; | |
| 3205 if (NILP (prev)) | |
| 3206 Vall_ephemerons = next; | |
| 3207 else | |
| 3208 XSET_EPHEMERON_NEXT (prev, next); | |
| 3209 } | |
| 3210 else | |
| 3211 prev = rest; | |
| 3212 } | |
| 3213 else | |
| 3214 prev = rest; | |
| 3215 | |
| 3216 rest = next; | |
| 3217 } | |
| 3218 | |
| 3219 return did_mark; | |
| 3220 } | |
| 3221 | |
| 3222 /* At this point, everything that's in Vall_ephemerons is dead. | |
| 3223 * Well, almost: we still need to run the finalizers, so we need to | |
| 3224 * resurrect them. | |
| 3225 */ | |
| 3226 | |
| 888 | 3227 int |
|
5752
70a3f4ff8da8
Improve coding style, variable names, data.c, sequence.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5736
diff
changeset
|
3228 finish_marking_ephemerons (void) |
| 888 | 3229 { |
| 1590 | 3230 Lisp_Object rest = Vall_ephemerons, next, prev = Qnil; |
| 888 | 3231 int did_mark = 0; |
| 3232 | |
| 3233 while (! NILP (rest)) | |
| 3234 { | |
| 3235 next = XEPHEMERON_NEXT (rest); | |
| 3236 | |
| 3237 if (marked_p (rest)) | |
| 1590 | 3238 /* The ephemeron itself is live, but its key is garbage */ |
| 888 | 3239 { |
| 1590 | 3240 /* tombstone */ |
| 3241 XSET_EPHEMERON_VALUE (rest, Qnil); | |
| 3242 | |
| 3243 if (! NILP (XEPHEMERON_FINALIZER (rest))) | |
| 888 | 3244 { |
| 1590 | 3245 MARK_CONS (XCONS (XEPHEMERON (rest)->cons_chain)); |
| 1598 | 3246 #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
|
3247 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
|
3248 (XCAR (XEPHEMERON (rest)->cons_chain)); |
| 1598 | 3249 #else /* NOT USE_KKCC */ |
| 1590 | 3250 mark_object (XCAR (XEPHEMERON (rest)->cons_chain)); |
| 1598 | 3251 #endif /* NOT USE_KKCC */ |
| 1590 | 3252 |
| 3253 /* Register the finalizer */ | |
| 3254 XSET_EPHEMERON_NEXT (rest, Vfinalize_list); | |
| 3255 Vfinalize_list = XEPHEMERON (rest)->cons_chain; | |
| 3256 did_mark = 1; | |
| 888 | 3257 } |
| 3258 | |
| 3259 /* Remove it from the list. */ | |
| 3260 if (NILP (prev)) | |
| 3261 Vall_ephemerons = next; | |
| 3262 else | |
| 3263 XSET_EPHEMERON_NEXT (prev, next); | |
| 3264 } | |
| 3265 else | |
| 3266 prev = rest; | |
| 3267 | |
| 3268 rest = next; | |
| 3269 } | |
| 1590 | 3270 |
| 3271 return did_mark; | |
| 3272 } | |
| 3273 | |
| 3274 void | |
|
5752
70a3f4ff8da8
Improve coding style, variable names, data.c, sequence.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5736
diff
changeset
|
3275 prune_ephemerons (void) |
| 1590 | 3276 { |
| 3277 Vall_ephemerons = Vnew_all_ephemerons; | |
| 888 | 3278 } |
| 3279 | |
| 3280 Lisp_Object | |
|
5752
70a3f4ff8da8
Improve coding style, variable names, data.c, sequence.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5736
diff
changeset
|
3281 zap_finalize_list (void) |
| 888 | 3282 { |
| 3283 Lisp_Object finalizers = Vfinalize_list; | |
| 3284 | |
| 3285 Vfinalize_list = Qnil; | |
| 3286 | |
| 3287 return finalizers; | |
| 3288 } | |
| 3289 | |
| 3290 static Lisp_Object | |
| 2286 | 3291 mark_ephemeron (Lisp_Object UNUSED (obj)) |
| 888 | 3292 { |
| 3293 return Qnil; | |
| 3294 } | |
| 3295 | |
| 3296 static void | |
|
5325
47298dcf2e8f
Be more helpful in printing ephemerons, weak lists, and weak boxes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5307
diff
changeset
|
3297 print_ephemeron (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) |
| 888 | 3298 { |
| 3299 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
|
3300 { |
|
47298dcf2e8f
Be more helpful in printing ephemerons, weak lists, and weak boxes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5307
diff
changeset
|
3301 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
|
3302 } |
|
47298dcf2e8f
Be more helpful in printing ephemerons, weak lists, and weak boxes.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5307
diff
changeset
|
3303 |
|
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, "#<ephemeron :key "); |
|
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)->key, 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, " :value "); |
|
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 (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
|
3308 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
|
3309 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
|
3310 write_fmt_string (printcharfun, " 0x%x>", LISP_OBJECT_UID (obj)); |
| 888 | 3311 } |
| 3312 | |
| 3313 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
|
3314 ephemeron_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, int foldcase) |
| 888 | 3315 { |
| 3316 return | |
|
5752
70a3f4ff8da8
Improve coding style, variable names, data.c, sequence.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5736
diff
changeset
|
3317 internal_equal_0 (XEPHEMERON_REF (obj1), XEPHEMERON_REF (obj2), |
|
70a3f4ff8da8
Improve coding style, variable names, data.c, sequence.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5736
diff
changeset
|
3318 depth + 1, foldcase); |
| 888 | 3319 } |
| 3320 | |
| 3321 static Hashcode | |
|
5752
70a3f4ff8da8
Improve coding style, variable names, data.c, sequence.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5736
diff
changeset
|
3322 ephemeron_hash (Lisp_Object obj, int depth, Boolint equalp) |
| 888 | 3323 { |
|
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
|
3324 return internal_hash (XEPHEMERON_REF (obj), depth + 1, equalp); |
| 888 | 3325 } |
| 3326 | |
| 3327 Lisp_Object | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
3328 make_ephemeron (Lisp_Object key, Lisp_Object value, Lisp_Object finalizer) |
| 888 | 3329 { |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
3330 Lisp_Object temp = Qnil; |
| 888 | 3331 struct gcpro gcpro1, gcpro2; |
|
5127
a9c41067dd88
more cleanups, terminology clarification, lots of doc work
Ben Wing <ben@xemacs.org>
parents:
5125
diff
changeset
|
3332 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
|
3333 struct ephemeron *eph = XEPHEMERON (result); |
| 888 | 3334 |
| 3335 eph->key = Qnil; | |
| 3336 eph->cons_chain = Qnil; | |
| 3337 eph->value = Qnil; | |
| 3338 | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
3339 result = wrap_ephemeron (eph); |
| 888 | 3340 GCPRO2 (result, temp); |
| 3341 | |
| 3342 eph->key = key; | |
|
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
3343 temp = Fcons (value, finalizer); |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
3344 eph->cons_chain = Fcons (temp, Vall_ephemerons); |
| 888 | 3345 eph->value = value; |
| 3346 | |
| 3347 Vall_ephemerons = result; | |
| 3348 | |
| 3349 UNGCPRO; | |
| 3350 return result; | |
| 3351 } | |
| 3352 | |
| 1598 | 3353 /* Ephemerons are special cases in the KKCC mark algorithm, so nothing |
| 3354 is marked here. */ | |
| 1204 | 3355 static const struct memory_description ephemeron_description[] = { |
|
5752
70a3f4ff8da8
Improve coding style, variable names, data.c, sequence.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5736
diff
changeset
|
3356 { XD_LISP_OBJECT, offsetof (struct ephemeron, key), |
| 2551 | 3357 0, { 0 }, XD_FLAG_NO_KKCC }, |
|
5752
70a3f4ff8da8
Improve coding style, variable names, data.c, sequence.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5736
diff
changeset
|
3358 { XD_LISP_OBJECT, offsetof (struct ephemeron, cons_chain), |
| 2551 | 3359 0, { 0 }, XD_FLAG_NO_KKCC }, |
|
5752
70a3f4ff8da8
Improve coding style, variable names, data.c, sequence.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5736
diff
changeset
|
3360 { XD_LISP_OBJECT, offsetof (struct ephemeron, value), |
| 2551 | 3361 0, { 0 }, XD_FLAG_NO_KKCC }, |
| 888 | 3362 { XD_END } |
| 3363 }; | |
| 3364 | |
|
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
3365 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
|
3366 mark_ephemeron, print_ephemeron, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
3367 0, ephemeron_equal, ephemeron_hash, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
3368 ephemeron_description, |
|
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
3369 struct ephemeron); |
| 888 | 3370 |
| 3371 DEFUN ("make-ephemeron", Fmake_ephemeron, 2, 3, 0, /* | |
| 1590 | 3372 Return a new ephemeron with key KEY, value VALUE, and finalizer FINALIZER. |
| 3373 The ephemeron is a reference to VALUE which may be extracted with | |
| 3374 `ephemeron-ref'. VALUE is only reachable through the ephemeron as | |
| 888 | 3375 long as KEY is reachable; the ephemeron does not contribute to the |
| 3376 reachability of KEY. When KEY becomes unreachable while the ephemeron | |
| 1590 | 3377 itself is still reachable, VALUE is queued for finalization: FINALIZER |
| 3378 will possibly be called on VALUE some time in the future. Moreover, | |
| 888 | 3379 future calls to `ephemeron-ref' will return NIL. |
| 3380 */ | |
| 3381 (key, value, finalizer)) | |
| 3382 { | |
|
5752
70a3f4ff8da8
Improve coding style, variable names, data.c, sequence.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5736
diff
changeset
|
3383 return make_ephemeron (key, value, finalizer); |
| 888 | 3384 } |
| 3385 | |
| 3386 DEFUN ("ephemeron-ref", Fephemeron_ref, 1, 1, 0, /* | |
| 3387 Return the contents of ephemeron EPHEMERON. | |
| 3388 If the contents have been GCed, return NIL. | |
| 3389 */ | |
|
5752
70a3f4ff8da8
Improve coding style, variable names, data.c, sequence.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5736
diff
changeset
|
3390 (ephemeron)) |
| 888 | 3391 { |
|
5752
70a3f4ff8da8
Improve coding style, variable names, data.c, sequence.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
5736
diff
changeset
|
3392 return XEPHEMERON_REF (ephemeron); |
| 888 | 3393 } |
| 3394 | |
| 3395 DEFUN ("ephemeron-p", Fephemeronp, 1, 1, 0, /* | |
| 3396 Return non-nil if OBJECT is an ephemeron. | |
| 3397 */ | |
| 3398 (object)) | |
| 3399 { | |
| 3400 return EPHEMERONP (object) ? Qt : Qnil; | |
| 3401 } | |
| 428 | 3402 |
| 3403 /************************************************************************/ | |
| 3404 /* initialization */ | |
| 3405 /************************************************************************/ | |
| 3406 | |
| 3407 static SIGTYPE | |
| 3408 arith_error (int signo) | |
| 3409 { | |
| 3410 EMACS_REESTABLISH_SIGNAL (signo, arith_error); | |
| 3411 EMACS_UNBLOCK_SIGNAL (signo); | |
| 563 | 3412 signal_error (Qarith_error, 0, Qunbound); |
| 428 | 3413 } |
| 3414 | |
| 3415 void | |
| 3416 init_data_very_early (void) | |
| 3417 { | |
| 3418 /* Don't do this if just dumping out. | |
| 3419 We don't want to call `signal' in this case | |
| 3420 so that we don't have trouble with dumping | |
| 3421 signal-delivering routines in an inconsistent state. */ | |
| 3422 if (!initialized) | |
| 3423 return; | |
| 613 | 3424 EMACS_SIGNAL (SIGFPE, arith_error); |
| 428 | 3425 #ifdef uts |
| 613 | 3426 EMACS_SIGNAL (SIGEMT, arith_error); |
| 428 | 3427 #endif /* uts */ |
| 3428 } | |
| 3429 | |
| 3430 void | |
| 3431 init_errors_once_early (void) | |
| 3432 { | |
| 442 | 3433 DEFSYMBOL (Qerror_conditions); |
| 3434 DEFSYMBOL (Qerror_message); | |
| 428 | 3435 |
| 3436 /* We declare the errors here because some other deferrors depend | |
| 3437 on some of the errors below. */ | |
| 3438 | |
| 3439 /* ERROR is used as a signaler for random errors for which nothing | |
| 3440 else is right */ | |
| 3441 | |
| 442 | 3442 DEFERROR (Qerror, "error", Qnil); |
| 3443 DEFERROR_STANDARD (Qquit, Qnil); | |
| 428 | 3444 |
| 563 | 3445 DEFERROR_STANDARD (Qinvalid_argument, Qerror); |
| 3446 | |
| 3447 DEFERROR_STANDARD (Qsyntax_error, Qinvalid_argument); | |
| 442 | 3448 DEFERROR_STANDARD (Qinvalid_read_syntax, Qsyntax_error); |
| 563 | 3449 DEFERROR_STANDARD (Qstructure_formation_error, Qsyntax_error); |
| 3450 DEFERROR_STANDARD (Qlist_formation_error, Qstructure_formation_error); | |
| 442 | 3451 DEFERROR_STANDARD (Qmalformed_list, Qlist_formation_error); |
| 3452 DEFERROR_STANDARD (Qmalformed_property_list, Qmalformed_list); | |
| 3453 DEFERROR_STANDARD (Qcircular_list, Qlist_formation_error); | |
| 3454 DEFERROR_STANDARD (Qcircular_property_list, Qcircular_list); | |
| 428 | 3455 |
| 442 | 3456 DEFERROR_STANDARD (Qwrong_type_argument, Qinvalid_argument); |
| 3457 DEFERROR_STANDARD (Qargs_out_of_range, Qinvalid_argument); | |
| 3458 DEFERROR_STANDARD (Qwrong_number_of_arguments, Qinvalid_argument); | |
| 3459 DEFERROR_STANDARD (Qinvalid_function, Qinvalid_argument); | |
| 563 | 3460 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
|
3461 DEFERROR_STANDARD (Qinvalid_keyword_argument, Qinvalid_argument); |
| 442 | 3462 DEFERROR (Qno_catch, "No catch for tag", Qinvalid_argument); |
| 3463 | |
| 563 | 3464 DEFERROR_STANDARD (Qinvalid_state, Qerror); |
| 442 | 3465 DEFERROR (Qvoid_function, "Symbol's function definition is void", |
| 3466 Qinvalid_state); | |
| 3467 DEFERROR (Qcyclic_function_indirection, | |
| 3468 "Symbol's chain of function indirections contains a loop", | |
| 3469 Qinvalid_state); | |
| 3470 DEFERROR (Qvoid_variable, "Symbol's value as variable is void", | |
| 3471 Qinvalid_state); | |
| 3472 DEFERROR (Qcyclic_variable_indirection, | |
| 3473 "Symbol's chain of variable indirections contains a loop", | |
| 3474 Qinvalid_state); | |
| 563 | 3475 DEFERROR_STANDARD (Qstack_overflow, Qinvalid_state); |
| 3476 DEFERROR_STANDARD (Qinternal_error, Qinvalid_state); | |
| 3477 DEFERROR_STANDARD (Qout_of_memory, Qinvalid_state); | |
| 428 | 3478 |
| 563 | 3479 DEFERROR_STANDARD (Qinvalid_operation, Qerror); |
| 3480 DEFERROR_STANDARD (Qinvalid_change, Qinvalid_operation); | |
| 442 | 3481 DEFERROR (Qsetting_constant, "Attempt to set a constant symbol", |
| 3482 Qinvalid_change); | |
| 563 | 3483 DEFERROR_STANDARD (Qprinting_unreadable_object, Qinvalid_operation); |
| 3484 DEFERROR (Qunimplemented, "Feature not yet implemented", Qinvalid_operation); | |
| 442 | 3485 |
| 563 | 3486 DEFERROR_STANDARD (Qediting_error, Qinvalid_operation); |
| 442 | 3487 DEFERROR_STANDARD (Qbeginning_of_buffer, Qediting_error); |
| 3488 DEFERROR_STANDARD (Qend_of_buffer, Qediting_error); | |
| 3489 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
|
3490 DEFERROR (Qextent_read_only, "Extent is read-only", Qediting_error); |
| 442 | 3491 |
| 3492 DEFERROR (Qio_error, "IO Error", Qinvalid_operation); | |
| 563 | 3493 DEFERROR_STANDARD (Qfile_error, Qio_error); |
| 3494 DEFERROR (Qend_of_file, "End of file or stream", Qfile_error); | |
| 3495 DEFERROR_STANDARD (Qconversion_error, Qio_error); | |
| 580 | 3496 DEFERROR_STANDARD (Qtext_conversion_error, Qconversion_error); |
| 442 | 3497 |
| 3498 DEFERROR (Qarith_error, "Arithmetic error", Qinvalid_operation); | |
| 3499 DEFERROR (Qrange_error, "Arithmetic range error", Qarith_error); | |
| 3500 DEFERROR (Qdomain_error, "Arithmetic domain error", Qarith_error); | |
| 3501 DEFERROR (Qsingularity_error, "Arithmetic singularity error", Qdomain_error); | |
| 3502 DEFERROR (Qoverflow_error, "Arithmetic overflow error", Qdomain_error); | |
| 3503 DEFERROR (Qunderflow_error, "Arithmetic underflow error", Qdomain_error); | |
| 428 | 3504 } |
| 3505 | |
| 3506 void | |
| 3507 syms_of_data (void) | |
| 3508 { | |
|
5117
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_list); |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
3510 INIT_LISP_OBJECT (ephemeron); |
|
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3017
diff
changeset
|
3511 INIT_LISP_OBJECT (weak_box); |
| 442 | 3512 |
| 3513 DEFSYMBOL (Qlambda); | |
| 3514 DEFSYMBOL (Qlistp); | |
| 3515 DEFSYMBOL (Qtrue_list_p); | |
| 3516 DEFSYMBOL (Qconsp); | |
| 3517 DEFSYMBOL (Qsubrp); | |
| 3518 DEFSYMBOL (Qsymbolp); | |
| 3519 DEFSYMBOL (Qintegerp); | |
| 3520 DEFSYMBOL (Qcharacterp); | |
| 3521 DEFSYMBOL (Qnatnump); | |
| 1983 | 3522 DEFSYMBOL (Qnonnegativep); |
| 442 | 3523 DEFSYMBOL (Qstringp); |
| 3524 DEFSYMBOL (Qarrayp); | |
| 3525 DEFSYMBOL (Qsequencep); | |
| 3526 DEFSYMBOL (Qbufferp); | |
| 3527 DEFSYMBOL (Qbitp); | |
| 3528 DEFSYMBOL_MULTIWORD_PREDICATE (Qbit_vectorp); | |
| 3529 DEFSYMBOL (Qvectorp); | |
| 3530 DEFSYMBOL (Qchar_or_string_p); | |
| 3531 DEFSYMBOL (Qmarkerp); | |
| 3532 DEFSYMBOL (Qinteger_or_marker_p); | |
| 3533 DEFSYMBOL (Qinteger_or_char_p); | |
| 3534 DEFSYMBOL (Qinteger_char_or_marker_p); | |
| 3535 DEFSYMBOL (Qnumberp); | |
| 3536 DEFSYMBOL (Qnumber_char_or_marker_p); | |
| 3537 DEFSYMBOL (Qcdr); | |
| 563 | 3538 DEFSYMBOL (Qerror_lacks_explanatory_string); |
| 442 | 3539 DEFSYMBOL_MULTIWORD_PREDICATE (Qweak_listp); |
| 3540 DEFSYMBOL (Qfloatp); | |
| 428 | 3541 |
| 3542 DEFSUBR (Fwrong_type_argument); | |
| 3543 | |
| 1983 | 3544 #ifdef HAVE_RATIO |
| 3545 DEFSUBR (Fdiv); | |
| 3546 #endif | |
| 428 | 3547 DEFSUBR (Feq); |
| 3548 DEFSUBR (Fnull); | |
| 3549 Ffset (intern ("not"), intern ("null")); | |
| 3550 DEFSUBR (Flistp); | |
| 3551 DEFSUBR (Fnlistp); | |
| 3552 DEFSUBR (Ftrue_list_p); | |
| 3553 DEFSUBR (Fconsp); | |
| 3554 DEFSUBR (Fatom); | |
| 3555 DEFSUBR (Fchar_or_string_p); | |
| 3556 DEFSUBR (Fcharacterp); | |
| 3557 DEFSUBR (Fchar_int_p); | |
| 3558 DEFSUBR (Fchar_to_int); | |
| 3559 DEFSUBR (Fint_to_char); | |
| 3560 DEFSUBR (Fchar_or_char_int_p); | |
| 1983 | 3561 DEFSUBR (Ffixnump); |
| 428 | 3562 DEFSUBR (Fintegerp); |
| 3563 DEFSUBR (Finteger_or_marker_p); | |
| 3564 DEFSUBR (Finteger_or_char_p); | |
| 3565 DEFSUBR (Finteger_char_or_marker_p); | |
| 3566 DEFSUBR (Fnumberp); | |
| 3567 DEFSUBR (Fnumber_or_marker_p); | |
| 3568 DEFSUBR (Fnumber_char_or_marker_p); | |
| 3569 DEFSUBR (Ffloatp); | |
| 3570 DEFSUBR (Fnatnump); | |
| 1983 | 3571 DEFSUBR (Fnonnegativep); |
| 428 | 3572 DEFSUBR (Fsymbolp); |
| 3573 DEFSUBR (Fkeywordp); | |
| 3574 DEFSUBR (Fstringp); | |
| 3575 DEFSUBR (Fvectorp); | |
| 3576 DEFSUBR (Fbitp); | |
| 3577 DEFSUBR (Fbit_vector_p); | |
| 3578 DEFSUBR (Farrayp); | |
| 3579 DEFSUBR (Fsequencep); | |
| 3580 DEFSUBR (Fmarkerp); | |
| 3581 DEFSUBR (Fsubrp); | |
| 3582 DEFSUBR (Fsubr_min_args); | |
| 3583 DEFSUBR (Fsubr_max_args); | |
| 3584 DEFSUBR (Fsubr_interactive); | |
| 3585 DEFSUBR (Ftype_of); | |
| 3586 DEFSUBR (Fcar); | |
| 3587 DEFSUBR (Fcdr); | |
| 3588 DEFSUBR (Fcar_safe); | |
| 3589 DEFSUBR (Fcdr_safe); | |
| 3590 DEFSUBR (Fsetcar); | |
| 3591 DEFSUBR (Fsetcdr); | |
| 3592 DEFSUBR (Findirect_function); | |
| 3593 DEFSUBR (Faref); | |
| 3594 DEFSUBR (Faset); | |
| 3595 | |
| 3596 DEFSUBR (Fnumber_to_string); | |
| 3597 DEFSUBR (Fstring_to_number); | |
| 3598 DEFSUBR (Feqlsign); | |
| 3599 DEFSUBR (Flss); | |
| 3600 DEFSUBR (Fgtr); | |
| 3601 DEFSUBR (Fleq); | |
| 3602 DEFSUBR (Fgeq); | |
| 3603 DEFSUBR (Fneq); | |
| 3604 DEFSUBR (Fzerop); | |
| 3605 DEFSUBR (Fplus); | |
| 3606 DEFSUBR (Fminus); | |
| 3607 DEFSUBR (Ftimes); | |
| 3608 DEFSUBR (Fquo); | |
| 3609 DEFSUBR (Frem); | |
| 3610 DEFSUBR (Fmod); | |
| 3611 DEFSUBR (Fmax); | |
| 3612 DEFSUBR (Fmin); | |
| 3613 DEFSUBR (Flogand); | |
| 3614 DEFSUBR (Flogior); | |
| 3615 DEFSUBR (Flogxor); | |
| 3616 DEFSUBR (Flsh); | |
| 3617 DEFSUBR (Fash); | |
| 3618 DEFSUBR (Fadd1); | |
| 3619 DEFSUBR (Fsub1); | |
| 3620 DEFSUBR (Flognot); | |
| 3621 | |
| 3622 DEFSUBR (Fweak_list_p); | |
| 3623 DEFSUBR (Fmake_weak_list); | |
| 3624 DEFSUBR (Fweak_list_type); | |
| 3625 DEFSUBR (Fweak_list_list); | |
| 3626 DEFSUBR (Fset_weak_list_list); | |
| 858 | 3627 |
| 888 | 3628 DEFSUBR (Fmake_ephemeron); |
| 3629 DEFSUBR (Fephemeron_ref); | |
| 3630 DEFSUBR (Fephemeronp); | |
| 858 | 3631 DEFSUBR (Fmake_weak_box); |
| 3632 DEFSUBR (Fweak_box_ref); | |
| 3633 DEFSUBR (Fweak_boxp); | |
| 428 | 3634 } |
| 3635 | |
| 3636 void | |
| 3637 vars_of_data (void) | |
| 3638 { | |
| 3639 /* This must not be staticpro'd */ | |
| 3640 Vall_weak_lists = Qnil; | |
| 452 | 3641 dump_add_weak_object_chain (&Vall_weak_lists); |
| 428 | 3642 |
| 888 | 3643 Vall_ephemerons = Qnil; |
| 3644 dump_add_weak_object_chain (&Vall_ephemerons); | |
| 3645 | |
| 3646 Vfinalize_list = Qnil; | |
| 3647 staticpro (&Vfinalize_list); | |
| 3648 | |
| 858 | 3649 Vall_weak_boxes = Qnil; |
| 3650 dump_add_weak_object_chain (&Vall_weak_boxes); | |
| 3651 | |
|
4885
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
3652 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
|
3653 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
|
3654 */); |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
3655 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
|
3656 |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4846
diff
changeset
|
3657 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
|
3658 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
|
3659 */); |
|
5581
56144c8593a8
Mechanically change INT to FIXNUM in our sources.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5510
diff
changeset
|
3660 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
|
3661 |
| 428 | 3662 #ifdef DEBUG_XEMACS |
| 3663 DEFVAR_BOOL ("debug-issue-ebola-notices", &debug_issue_ebola_notices /* | |
| 3664 If non-zero, note when your code may be suffering from char-int confoundance. | |
| 3665 That is to say, if XEmacs encounters a usage of `eq', `memq', `equal', | |
| 3666 etc. where an int and a char with the same value are being compared, | |
| 3667 it will issue a notice on stderr to this effect, along with a backtrace. | |
| 3668 In such situations, the result would be different in XEmacs 19 versus | |
| 3669 XEmacs 20, and you probably don't want this. | |
| 3670 | |
| 3671 Note that in order to see these notices, you have to byte compile your | |
| 3672 code under XEmacs 20 -- any code byte-compiled under XEmacs 19 will | |
| 3673 have its chars and ints all confounded in the byte code, making it | |
| 3674 impossible to accurately determine Ebola infection. | |
| 3675 */ ); | |
| 3676 | |
| 3677 debug_issue_ebola_notices = 0; | |
| 3678 | |
| 3679 DEFVAR_INT ("debug-ebola-backtrace-length", | |
| 3680 &debug_ebola_backtrace_length /* | |
| 3681 Length (in stack frames) of short backtrace printed out in Ebola notices. | |
| 3682 See `debug-issue-ebola-notices'. | |
| 3683 */ ); | |
| 3684 debug_ebola_backtrace_length = 32; | |
| 3685 | |
| 3686 #endif /* DEBUG_XEMACS */ | |
| 3687 } |