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