Mercurial > hg > xemacs-beta
annotate src/number.c @ 5127:a9c41067dd88 ben-lisp-object
more cleanups, terminology clarification, lots of doc work
-------------------- ChangeLog entries follow: --------------------
man/ChangeLog addition:
2010-03-05 Ben Wing <ben@xemacs.org>
* internals/internals.texi (Introduction to Allocation):
* internals/internals.texi (Integers and Characters):
* internals/internals.texi (Allocation from Frob Blocks):
* internals/internals.texi (lrecords):
* internals/internals.texi (Low-level allocation):
Rewrite section on allocation of Lisp objects to reflect the new
reality. Remove references to nonexistent XSETINT and XSETCHAR.
modules/ChangeLog addition:
2010-03-05 Ben Wing <ben@xemacs.org>
* postgresql/postgresql.c (allocate_pgconn):
* postgresql/postgresql.c (allocate_pgresult):
* postgresql/postgresql.h (struct Lisp_PGconn):
* postgresql/postgresql.h (struct Lisp_PGresult):
* ldap/eldap.c (allocate_ldap):
* ldap/eldap.h (struct Lisp_LDAP):
Same changes as in src/ dir. See large log there in ChangeLog,
but basically:
ALLOC_LISP_OBJECT -> ALLOC_NORMAL_LISP_OBJECT
LISP_OBJECT_HEADER -> NORMAL_LISP_OBJECT_HEADER
../hlo/src/ChangeLog addition:
2010-03-05 Ben Wing <ben@xemacs.org>
* alloc.c:
* alloc.c (old_alloc_sized_lcrecord):
* alloc.c (very_old_free_lcrecord):
* alloc.c (copy_lisp_object):
* alloc.c (zero_sized_lisp_object):
* alloc.c (zero_nonsized_lisp_object):
* alloc.c (lisp_object_storage_size):
* alloc.c (free_normal_lisp_object):
* alloc.c (FREE_FIXED_TYPE_WHEN_NOT_IN_GC):
* alloc.c (ALLOC_FROB_BLOCK_LISP_OBJECT):
* alloc.c (Fcons):
* alloc.c (noseeum_cons):
* alloc.c (make_float):
* alloc.c (make_bignum):
* alloc.c (make_bignum_bg):
* alloc.c (make_ratio):
* alloc.c (make_ratio_bg):
* alloc.c (make_ratio_rt):
* alloc.c (make_bigfloat):
* alloc.c (make_bigfloat_bf):
* alloc.c (size_vector):
* alloc.c (make_compiled_function):
* alloc.c (Fmake_symbol):
* alloc.c (allocate_extent):
* alloc.c (allocate_event):
* alloc.c (make_key_data):
* alloc.c (make_button_data):
* alloc.c (make_motion_data):
* alloc.c (make_process_data):
* alloc.c (make_timeout_data):
* alloc.c (make_magic_data):
* alloc.c (make_magic_eval_data):
* alloc.c (make_eval_data):
* alloc.c (make_misc_user_data):
* alloc.c (Fmake_marker):
* alloc.c (noseeum_make_marker):
* alloc.c (size_string_direct_data):
* alloc.c (make_uninit_string):
* alloc.c (make_string_nocopy):
* alloc.c (mark_lcrecord_list):
* alloc.c (alloc_managed_lcrecord):
* alloc.c (free_managed_lcrecord):
* alloc.c (sweep_lcrecords_1):
* alloc.c (malloced_storage_size):
* buffer.c (allocate_buffer):
* buffer.c (compute_buffer_usage):
* buffer.c (DEFVAR_BUFFER_LOCAL_1):
* buffer.c (nuke_all_buffer_slots):
* buffer.c (common_init_complex_vars_of_buffer):
* buffer.h (struct buffer_text):
* buffer.h (struct buffer):
* bytecode.c:
* bytecode.c (make_compiled_function_args):
* bytecode.c (size_compiled_function_args):
* bytecode.h (struct compiled_function_args):
* casetab.c (allocate_case_table):
* casetab.h (struct Lisp_Case_Table):
* charset.h (struct Lisp_Charset):
* chartab.c (fill_char_table):
* chartab.c (Fmake_char_table):
* chartab.c (make_char_table_entry):
* chartab.c (copy_char_table_entry):
* chartab.c (Fcopy_char_table):
* chartab.c (put_char_table):
* chartab.h (struct Lisp_Char_Table_Entry):
* chartab.h (struct Lisp_Char_Table):
* console-gtk-impl.h (struct gtk_device):
* console-gtk-impl.h (struct gtk_frame):
* console-impl.h (struct console):
* console-msw-impl.h (struct Lisp_Devmode):
* console-msw-impl.h (struct mswindows_device):
* console-msw-impl.h (struct msprinter_device):
* console-msw-impl.h (struct mswindows_frame):
* console-msw-impl.h (struct mswindows_dialog_id):
* console-stream-impl.h (struct stream_console):
* console-stream.c (stream_init_console):
* console-tty-impl.h (struct tty_console):
* console-tty-impl.h (struct tty_device):
* console-tty.c (allocate_tty_console_struct):
* console-x-impl.h (struct x_device):
* console-x-impl.h (struct x_frame):
* console.c (allocate_console):
* console.c (nuke_all_console_slots):
* console.c (DEFVAR_CONSOLE_LOCAL_1):
* console.c (common_init_complex_vars_of_console):
* data.c (make_weak_list):
* data.c (make_weak_box):
* data.c (make_ephemeron):
* database.c:
* database.c (struct Lisp_Database):
* database.c (allocate_database):
* database.c (finalize_database):
* device-gtk.c (allocate_gtk_device_struct):
* device-impl.h (struct device):
* device-msw.c:
* device-msw.c (mswindows_init_device):
* device-msw.c (msprinter_init_device):
* device-msw.c (finalize_devmode):
* device-msw.c (allocate_devmode):
* device-tty.c (allocate_tty_device_struct):
* device-x.c (allocate_x_device_struct):
* device.c:
* device.c (nuke_all_device_slots):
* device.c (allocate_device):
* dialog-msw.c (handle_question_dialog_box):
* elhash.c:
* elhash.c (struct Lisp_Hash_Table):
* elhash.c (finalize_hash_table):
* elhash.c (make_general_lisp_hash_table):
* elhash.c (Fcopy_hash_table):
* elhash.h (htentry):
* emacs.c (main_1):
* eval.c:
* eval.c (size_multiple_value):
* event-stream.c (finalize_command_builder):
* event-stream.c (allocate_command_builder):
* event-stream.c (free_command_builder):
* event-stream.c (event_stream_generate_wakeup):
* event-stream.c (event_stream_resignal_wakeup):
* event-stream.c (event_stream_disable_wakeup):
* event-stream.c (event_stream_wakeup_pending_p):
* events.h (struct Lisp_Timeout):
* events.h (struct command_builder):
* extents-impl.h:
* extents-impl.h (struct extent_auxiliary):
* extents-impl.h (struct extent_info):
* extents-impl.h (set_extent_no_chase_aux_field):
* extents-impl.h (set_extent_no_chase_normal_field):
* extents.c:
* extents.c (gap_array_marker):
* extents.c (gap_array):
* extents.c (extent_list_marker):
* extents.c (extent_list):
* extents.c (stack_of_extents):
* extents.c (gap_array_make_marker):
* extents.c (extent_list_make_marker):
* extents.c (allocate_extent_list):
* extents.c (SLOT):
* extents.c (mark_extent_auxiliary):
* extents.c (allocate_extent_auxiliary):
* extents.c (attach_extent_auxiliary):
* extents.c (size_gap_array):
* extents.c (finalize_extent_info):
* extents.c (allocate_extent_info):
* extents.c (uninit_buffer_extents):
* extents.c (allocate_soe):
* extents.c (copy_extent):
* extents.c (vars_of_extents):
* extents.h:
* faces.c (allocate_face):
* faces.h (struct Lisp_Face):
* faces.h (struct face_cachel):
* file-coding.c:
* file-coding.c (finalize_coding_system):
* file-coding.c (sizeof_coding_system):
* file-coding.c (Fcopy_coding_system):
* file-coding.h (struct Lisp_Coding_System):
* file-coding.h (MARKED_SLOT):
* fns.c (size_bit_vector):
* font-mgr.c:
* font-mgr.c (finalize_fc_pattern):
* font-mgr.c (print_fc_pattern):
* font-mgr.c (Ffc_pattern_p):
* font-mgr.c (Ffc_pattern_create):
* font-mgr.c (Ffc_name_parse):
* font-mgr.c (Ffc_name_unparse):
* font-mgr.c (Ffc_pattern_duplicate):
* font-mgr.c (Ffc_pattern_add):
* font-mgr.c (Ffc_pattern_del):
* font-mgr.c (Ffc_pattern_get):
* font-mgr.c (fc_config_create_using):
* font-mgr.c (fc_strlist_to_lisp_using):
* font-mgr.c (fontset_to_list):
* font-mgr.c (Ffc_config_p):
* font-mgr.c (Ffc_config_up_to_date):
* font-mgr.c (Ffc_config_build_fonts):
* font-mgr.c (Ffc_config_get_cache):
* font-mgr.c (Ffc_config_get_fonts):
* font-mgr.c (Ffc_config_set_current):
* font-mgr.c (Ffc_config_get_blanks):
* font-mgr.c (Ffc_config_get_rescan_interval):
* font-mgr.c (Ffc_config_set_rescan_interval):
* font-mgr.c (Ffc_config_app_font_add_file):
* font-mgr.c (Ffc_config_app_font_add_dir):
* font-mgr.c (Ffc_config_app_font_clear):
* font-mgr.c (size):
* font-mgr.c (Ffc_config_substitute):
* font-mgr.c (Ffc_font_render_prepare):
* font-mgr.c (Ffc_font_match):
* font-mgr.c (Ffc_font_sort):
* font-mgr.c (finalize_fc_config):
* font-mgr.c (print_fc_config):
* font-mgr.h:
* font-mgr.h (struct fc_pattern):
* font-mgr.h (XFC_PATTERN):
* font-mgr.h (struct fc_config):
* font-mgr.h (XFC_CONFIG):
* frame-gtk.c (allocate_gtk_frame_struct):
* frame-impl.h (struct frame):
* frame-msw.c (mswindows_init_frame_1):
* frame-x.c (allocate_x_frame_struct):
* frame.c (nuke_all_frame_slots):
* frame.c (allocate_frame_core):
* gc.c:
* gc.c (GC_CHECK_NOT_FREE):
* glyphs.c (finalize_image_instance):
* glyphs.c (allocate_image_instance):
* glyphs.c (Fcolorize_image_instance):
* glyphs.c (allocate_glyph):
* glyphs.c (unmap_subwindow_instance_cache_mapper):
* glyphs.c (register_ignored_expose):
* glyphs.h (struct Lisp_Image_Instance):
* glyphs.h (struct Lisp_Glyph):
* glyphs.h (struct glyph_cachel):
* glyphs.h (struct expose_ignore):
* gui.c (allocate_gui_item):
* gui.h (struct Lisp_Gui_Item):
* keymap.c (struct Lisp_Keymap):
* keymap.c (make_keymap):
* lisp.h:
* lisp.h (struct Lisp_String_Direct_Data):
* lisp.h (struct Lisp_String_Indirect_Data):
* lisp.h (struct Lisp_Vector):
* lisp.h (struct Lisp_Bit_Vector):
* lisp.h (DECLARE_INLINE_LISP_BIT_VECTOR):
* lisp.h (struct weak_box):
* lisp.h (struct ephemeron):
* lisp.h (struct weak_list):
* lrecord.h:
* lrecord.h (struct lrecord_implementation):
* lrecord.h (MC_ALLOC_CALL_FINALIZER):
* lrecord.h (struct lcrecord_list):
* lstream.c (finalize_lstream):
* lstream.c (sizeof_lstream):
* lstream.c (Lstream_new):
* lstream.c (Lstream_delete):
* lstream.h (struct lstream):
* marker.c:
* marker.c (finalize_marker):
* marker.c (compute_buffer_marker_usage):
* mule-charset.c:
* mule-charset.c (make_charset):
* mule-charset.c (compute_charset_usage):
* objects-impl.h (struct Lisp_Color_Instance):
* objects-impl.h (struct Lisp_Font_Instance):
* objects-tty-impl.h (struct tty_color_instance_data):
* objects-tty-impl.h (struct tty_font_instance_data):
* objects-tty.c (tty_initialize_color_instance):
* objects-tty.c (tty_initialize_font_instance):
* objects.c (finalize_color_instance):
* objects.c (Fmake_color_instance):
* objects.c (finalize_font_instance):
* objects.c (Fmake_font_instance):
* objects.c (reinit_vars_of_objects):
* opaque.c:
* opaque.c (sizeof_opaque):
* opaque.c (make_opaque_ptr):
* opaque.c (free_opaque_ptr):
* opaque.h:
* opaque.h (Lisp_Opaque):
* opaque.h (Lisp_Opaque_Ptr):
* print.c (printing_unreadable_lcrecord):
* print.c (external_object_printer):
* print.c (debug_p4):
* process.c (finalize_process):
* process.c (make_process_internal):
* procimpl.h (struct Lisp_Process):
* rangetab.c (Fmake_range_table):
* rangetab.c (Fcopy_range_table):
* rangetab.h (struct Lisp_Range_Table):
* scrollbar.c:
* scrollbar.c (create_scrollbar_instance):
* scrollbar.c (compute_scrollbar_instance_usage):
* scrollbar.h (struct scrollbar_instance):
* specifier.c (finalize_specifier):
* specifier.c (sizeof_specifier):
* specifier.c (set_specifier_caching):
* specifier.h (struct Lisp_Specifier):
* specifier.h (struct specifier_caching):
* symeval.h:
* symeval.h (SYMBOL_VALUE_MAGIC_P):
* symeval.h (DEFVAR_SYMVAL_FWD):
* symsinit.h:
* syntax.c (init_buffer_syntax_cache):
* syntax.h (struct syntax_cache):
* toolbar.c:
* toolbar.c (allocate_toolbar_button):
* toolbar.c (update_toolbar_button):
* toolbar.h (struct toolbar_button):
* tooltalk.c (struct Lisp_Tooltalk_Message):
* tooltalk.c (make_tooltalk_message):
* tooltalk.c (struct Lisp_Tooltalk_Pattern):
* tooltalk.c (make_tooltalk_pattern):
* ui-gtk.c:
* ui-gtk.c (allocate_ffi_data):
* ui-gtk.c (emacs_gtk_object_finalizer):
* ui-gtk.c (allocate_emacs_gtk_object_data):
* ui-gtk.c (allocate_emacs_gtk_boxed_data):
* ui-gtk.h:
* window-impl.h (struct window):
* window-impl.h (struct window_mirror):
* window.c (finalize_window):
* window.c (allocate_window):
* window.c (new_window_mirror):
* window.c (mark_window_as_deleted):
* window.c (make_dummy_parent):
* window.c (compute_window_mirror_usage):
* window.c (compute_window_usage):
Overall point of this change and previous ones in this repository:
(1) Introduce new, clearer terminology: everything other than int
or char is a "record" object, which comes in two types: "normal
objects" and "frob-block objects". Fix up all places that
referred to frob-block objects as "simple", "basic", etc.
(2) Provide an advertised interface for doing operations on Lisp
objects, including creating new types, that is clean and
consistent in its naming, uses the above-referenced terms and
avoids referencing "lrecords", "old lcrecords", etc., which should
hide under the surface.
(3) Make the size_in_bytes and finalizer methods take a
Lisp_Object rather than a void * for consistency with other methods.
(4) Separate finalizer method into finalizer and disksaver, so
that normal finalize methods don't have to worry about disksaving.
Other specifics:
(1) Renaming:
LISP_OBJECT_HEADER -> NORMAL_LISP_OBJECT_HEADER
ALLOC_LISP_OBJECT -> ALLOC_NORMAL_LISP_OBJECT
implementation->basic_p -> implementation->frob_block_p
ALLOCATE_FIXED_TYPE_AND_SET_IMPL -> ALLOC_FROB_BLOCK_LISP_OBJECT
*FCCONFIG*, wrap_fcconfig -> *FC_CONFIG*, wrap_fc_config
*FCPATTERN*, wrap_fcpattern -> *FC_PATTERN*, wrap_fc_pattern
(the last two changes make the naming of these macros consistent
with the naming of all other macros, since the objects are named
fc-config and fc-pattern with a hyphen)
(2) Lots of documentation fixes in lrecord.h.
(3) Eliminate macros for copying, freeing, zeroing objects, getting
their storage size. Instead, new functions:
zero_sized_lisp_object()
zero_nonsized_lisp_object()
lisp_object_storage_size()
free_normal_lisp_object()
(copy_lisp_object() already exists)
LISP_OBJECT_FROB_BLOCK_P() (actually a macro)
Eliminated:
free_lrecord()
zero_lrecord()
copy_lrecord()
copy_sized_lrecord()
old_copy_lcrecord()
old_copy_sized_lcrecord()
old_zero_lcrecord()
old_zero_sized_lcrecord()
LISP_OBJECT_STORAGE_SIZE()
COPY_SIZED_LISP_OBJECT()
COPY_SIZED_LCRECORD()
COPY_LISP_OBJECT()
ZERO_LISP_OBJECT()
FREE_LISP_OBJECT()
(4) Catch the remaining places where lrecord stuff was used directly
and use the advertised interface, e.g. alloc_sized_lrecord() ->
ALLOC_SIZED_LISP_OBJECT().
(5) Make certain statically-declared pseudo-objects
(buffer_local_flags, console_local_flags) have their lheader
initialized correctly, so things like copy_lisp_object() can work
on them. Make extent_auxiliary_defaults a proper heap object
Vextent_auxiliary_defaults, and make extent auxiliaries dumpable
so that this object can be dumped. allocate_extent_auxiliary()
now just creates the object, and attach_extent_auxiliary()
creates an extent auxiliary and attaches to an extent, like the
old allocate_extent_auxiliary().
(6) Create EXTENT_AUXILIARY_SLOTS macro, similar to the foo-slots.h
files but in a macro instead of a file. The purpose is to avoid
duplication when iterating over all the slots in an extent auxiliary.
Use it.
(7) In lstream.c, don't zero out object after allocation because
allocation routines take care of this.
(8) In marker.c, fix a mistake in computing marker overhead.
(9) In print.c, clean up printing_unreadable_lcrecord(),
external_object_printer() to avoid lots of ifdef NEW_GC's.
(10) Separate toolbar-button allocation into a separate
allocate_toolbar_button() function for use in the example code
in lrecord.h.
author | Ben Wing <ben@xemacs.org> |
---|---|
date | Fri, 05 Mar 2010 04:08:17 -0600 |
parents | b5df3737028a |
children | 0dcd22290039 |
rev | line source |
---|---|
1983 | 1 /* Numeric types for XEmacs. |
2 Copyright (C) 2004 Jerry James. | |
5125 | 3 Copyright (C) 2010 Ben Wing. |
1983 | 4 |
5 This file is part of XEmacs. | |
6 | |
7 XEmacs is free software; you can redistribute it and/or modify it | |
8 under the terms of the GNU General Public License as published by the | |
9 Free Software Foundation; either version 2, or (at your option) any | |
10 later version. | |
11 | |
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
15 for more details. | |
16 | |
17 You should have received a copy of the GNU General Public License | |
18 along with XEmacs; see the file COPYING. If not, write to | |
4802
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
19 the Free Software Foundation, Inc., 51 Franklin St - Fifth Floor, |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
20 Boston, MA 02111-1301, USA. */ |
1983 | 21 |
22 /* Synched up with: Not in FSF. */ | |
23 | |
24 #include <config.h> | |
25 #include <limits.h> | |
26 #include "lisp.h" | |
27 | |
2595 | 28 #ifdef HAVE_BIGFLOAT |
29 #define USED_IF_BIGFLOAT(decl) decl | |
30 #else | |
31 #define USED_IF_BIGFLOAT(decl) UNUSED (decl) | |
32 #endif | |
33 | |
2001 | 34 Lisp_Object Qrationalp, Qfloatingp, Qrealp; |
1983 | 35 Lisp_Object Vdefault_float_precision; |
4885
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4802
diff
changeset
|
36 |
1983 | 37 static Lisp_Object Qunsupported_type; |
38 static Lisp_Object Vbigfloat_max_prec; | |
39 static int number_initialized; | |
40 | |
41 #ifdef HAVE_BIGNUM | |
42 bignum scratch_bignum, scratch_bignum2; | |
43 #endif | |
44 #ifdef HAVE_RATIO | |
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3391
diff
changeset
|
45 ratio scratch_ratio, scratch_ratio2; |
1983 | 46 #endif |
47 #ifdef HAVE_BIGFLOAT | |
48 bigfloat scratch_bigfloat, scratch_bigfloat2; | |
49 #endif | |
50 | |
51 /********************************* Bignums **********************************/ | |
52 #ifdef HAVE_BIGNUM | |
53 static void | |
2286 | 54 bignum_print (Lisp_Object obj, Lisp_Object printcharfun, |
55 int UNUSED (escapeflag)) | |
1983 | 56 { |
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4883
diff
changeset
|
57 Ascbyte *bstr = bignum_to_string (XBIGNUM_DATA (obj), 10); |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4883
diff
changeset
|
58 write_ascstring (printcharfun, bstr); |
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
59 xfree (bstr); |
1983 | 60 } |
61 | |
4802
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
62 #ifdef NEW_GC |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
63 static void |
5125 | 64 bignum_finalize (void *header) |
4802
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
65 { |
5125 | 66 struct Lisp_Bignum *num = (struct Lisp_Bignum *) header; |
67 /* #### WARNING: It would be better to put some sort of check to make | |
68 sure this doesn't happen more than once, just in case --- | |
69 e.g. checking if it's zero before finalizing and then setting it to | |
70 zero after finalizing. */ | |
71 bignum_fini (num->data); | |
4802
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
72 } |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
73 #define BIGNUM_FINALIZE bignum_finalize |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
74 #else |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
75 #define BIGNUM_FINALIZE 0 |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
76 #endif |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
77 |
1983 | 78 static int |
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4892
diff
changeset
|
79 bignum_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth), |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4892
diff
changeset
|
80 int UNUSED (foldcase)) |
1983 | 81 { |
82 return bignum_eql (XBIGNUM_DATA (obj1), XBIGNUM_DATA (obj2)); | |
83 } | |
84 | |
85 static Hashcode | |
2286 | 86 bignum_hash (Lisp_Object obj, int UNUSED (depth)) |
1983 | 87 { |
88 return bignum_hashcode (XBIGNUM_DATA (obj)); | |
89 } | |
90 | |
2551 | 91 static void |
92 bignum_convert (const void *object, void **data, Bytecount *size) | |
93 { | |
94 CIbyte *bstr = bignum_to_string (*(bignum *)object, 10); | |
95 *data = bstr; | |
96 *size = strlen(bstr)+1; | |
97 } | |
98 | |
99 static void | |
100 bignum_convfree (const void * UNUSED (object), void *data, | |
101 Bytecount UNUSED (size)) | |
102 { | |
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
103 xfree (data); |
2551 | 104 } |
105 | |
106 static void * | |
107 bignum_deconvert (void *object, void *data, Bytecount UNUSED (size)) | |
108 { | |
109 bignum *b = (bignum *) object; | |
110 bignum_init(*b); | |
111 bignum_set_string(*b, (const char *) data, 10); | |
112 return object; | |
113 } | |
114 | |
115 static const struct opaque_convert_functions bignum_opc = { | |
116 bignum_convert, | |
117 bignum_convfree, | |
118 bignum_deconvert | |
119 }; | |
120 | |
1983 | 121 static const struct memory_description bignum_description[] = { |
2551 | 122 { XD_OPAQUE_DATA_CONVERTIBLE, offsetof (Lisp_Bignum, data), |
123 0, { &bignum_opc }, XD_FLAG_NO_KKCC }, | |
1983 | 124 { XD_END } |
125 }; | |
126 | |
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
127 DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT ("bignum", bignum, 0, bignum_print, |
5125 | 128 BIGNUM_FINALIZE, bignum_equal, |
129 bignum_hash, bignum_description, | |
130 Lisp_Bignum); | |
1983 | 131 |
2092 | 132 #endif /* HAVE_BIGNUM */ |
1983 | 133 |
134 Lisp_Object Qbignump; | |
135 | |
136 DEFUN ("bignump", Fbignump, 1, 1, 0, /* | |
137 Return t if OBJECT is a bignum, nil otherwise. | |
138 */ | |
139 (object)) | |
140 { | |
141 return BIGNUMP (object) ? Qt : Qnil; | |
142 } | |
143 | |
144 | |
145 /********************************** Ratios **********************************/ | |
146 #ifdef HAVE_RATIO | |
147 static void | |
2286 | 148 ratio_print (Lisp_Object obj, Lisp_Object printcharfun, |
149 int UNUSED (escapeflag)) | |
1983 | 150 { |
151 CIbyte *rstr = ratio_to_string (XRATIO_DATA (obj), 10); | |
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4883
diff
changeset
|
152 write_ascstring (printcharfun, rstr); |
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
153 xfree (rstr); |
1983 | 154 } |
155 | |
4802
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
156 #ifdef NEW_GC |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
157 static void |
5125 | 158 ratio_finalize (void *header) |
4802
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
159 { |
5125 | 160 struct Lisp_Ratio *num = (struct Lisp_Ratio *) header; |
161 /* #### WARNING: It would be better to put some sort of check to make | |
162 sure this doesn't happen more than once, just in case --- | |
163 e.g. checking if it's zero before finalizing and then setting it to | |
164 zero after finalizing. */ | |
165 ratio_fini (num->data); | |
4802
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
166 } |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
167 #define RATIO_FINALIZE ratio_finalize |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
168 #else |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
169 #define RATIO_FINALIZE 0 |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
170 #endif |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
171 |
1983 | 172 static int |
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4892
diff
changeset
|
173 ratio_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth), |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4892
diff
changeset
|
174 int UNUSED (foldcase)) |
1983 | 175 { |
176 return ratio_eql (XRATIO_DATA (obj1), XRATIO_DATA (obj2)); | |
177 } | |
178 | |
179 static Hashcode | |
2286 | 180 ratio_hash (Lisp_Object obj, int UNUSED (depth)) |
1983 | 181 { |
182 return ratio_hashcode (XRATIO_DATA (obj)); | |
183 } | |
184 | |
185 static const struct memory_description ratio_description[] = { | |
186 { XD_OPAQUE_PTR, offsetof (Lisp_Ratio, data) }, | |
187 { XD_END } | |
188 }; | |
189 | |
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
190 DEFINE_NODUMP_FROB_BLOCK_LISP_OBJECT ("ratio", ratio, 0, ratio_print, |
5125 | 191 RATIO_FINALIZE, ratio_equal, ratio_hash, |
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
192 ratio_description, Lisp_Ratio); |
1983 | 193 |
2092 | 194 #endif /* HAVE_RATIO */ |
1983 | 195 |
196 Lisp_Object Qratiop; | |
197 | |
198 DEFUN ("ratiop", Fratiop, 1, 1, 0, /* | |
199 Return t if OBJECT is a ratio, nil otherwise. | |
200 */ | |
201 (object)) | |
202 { | |
203 return RATIOP (object) ? Qt : Qnil; | |
204 } | |
205 | |
206 | |
207 /******************************** Rationals *********************************/ | |
208 DEFUN ("rationalp", Frationalp, 1, 1, 0, /* | |
209 Return t if OBJECT is a rational, nil otherwise. | |
210 */ | |
211 (object)) | |
212 { | |
213 return RATIONALP (object) ? Qt : Qnil; | |
214 } | |
215 | |
216 DEFUN ("numerator", Fnumerator, 1, 1, 0, /* | |
217 Return the numerator of the canonical form of RATIONAL. | |
218 If RATIONAL is an integer, RATIONAL is returned. | |
219 */ | |
220 (rational)) | |
221 { | |
222 CONCHECK_RATIONAL (rational); | |
223 #ifdef HAVE_RATIO | |
4883
f730384b8ddf
Be more careful about canonical integer forms when dealing with ratios.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4802
diff
changeset
|
224 if (RATIOP (rational)) |
f730384b8ddf
Be more careful about canonical integer forms when dealing with ratios.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4802
diff
changeset
|
225 { |
f730384b8ddf
Be more careful about canonical integer forms when dealing with ratios.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4802
diff
changeset
|
226 return |
f730384b8ddf
Be more careful about canonical integer forms when dealing with ratios.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4802
diff
changeset
|
227 Fcanonicalize_number (make_bignum_bg (XRATIO_NUMERATOR (rational))); |
f730384b8ddf
Be more careful about canonical integer forms when dealing with ratios.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4802
diff
changeset
|
228 } |
f730384b8ddf
Be more careful about canonical integer forms when dealing with ratios.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4802
diff
changeset
|
229 #endif |
1983 | 230 return rational; |
231 } | |
232 | |
233 DEFUN ("denominator", Fdenominator, 1, 1, 0, /* | |
234 Return the denominator of the canonical form of RATIONAL. | |
235 If RATIONAL is an integer, 1 is returned. | |
236 */ | |
237 (rational)) | |
238 { | |
239 CONCHECK_RATIONAL (rational); | |
240 #ifdef HAVE_RATIO | |
4883
f730384b8ddf
Be more careful about canonical integer forms when dealing with ratios.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4802
diff
changeset
|
241 if (RATIOP (rational)) |
f730384b8ddf
Be more careful about canonical integer forms when dealing with ratios.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4802
diff
changeset
|
242 { |
f730384b8ddf
Be more careful about canonical integer forms when dealing with ratios.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4802
diff
changeset
|
243 return Fcanonicalize_number (make_bignum_bg |
f730384b8ddf
Be more careful about canonical integer forms when dealing with ratios.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4802
diff
changeset
|
244 (XRATIO_DENOMINATOR (rational))); |
f730384b8ddf
Be more careful about canonical integer forms when dealing with ratios.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4802
diff
changeset
|
245 } |
4892
d1d4ce10c7b4
Fix the build problem in number.c
Aidan Kehoe <kehoea@parhasard.net>
parents:
4886
diff
changeset
|
246 #endif |
4885
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4802
diff
changeset
|
247 return make_int (1); |
1983 | 248 } |
249 | |
250 | |
251 /******************************** Bigfloats *********************************/ | |
252 #ifdef HAVE_BIGFLOAT | |
253 static void | |
2286 | 254 bigfloat_print (Lisp_Object obj, Lisp_Object printcharfun, |
255 int UNUSED (escapeflag)) | |
1983 | 256 { |
4952
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4883
diff
changeset
|
257 Ascbyte *fstr = bigfloat_to_string (XBIGFLOAT_DATA (obj), 10); |
19a72041c5ed
Mule-izing, various fixes related to char * arguments
Ben Wing <ben@xemacs.org>
parents:
4883
diff
changeset
|
258 write_ascstring (printcharfun, fstr); |
4976
16112448d484
Rename xfree(FOO, TYPE) -> xfree(FOO)
Ben Wing <ben@xemacs.org>
parents:
4962
diff
changeset
|
259 xfree (fstr); |
1983 | 260 } |
261 | |
4802
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
262 #ifdef NEW_GC |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
263 static void |
5125 | 264 bigfloat_finalize (void *header) |
4802
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
265 { |
5125 | 266 struct Lisp_Bigfloat *num = (struct Lisp_Bigfloat *) header; |
267 /* #### WARNING: It would be better to put some sort of check to make | |
268 sure this doesn't happen more than once, just in case --- | |
269 e.g. checking if it's zero before finalizing and then setting it to | |
270 zero after finalizing. */ | |
271 bigfloat_fini (num->bf); | |
4802
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
272 } |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
273 #define BIGFLOAT_FINALIZE bigfloat_finalize |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
274 #else |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
275 #define BIGFLOAT_FINALIZE 0 |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
276 #endif |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
277 |
1983 | 278 static int |
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4892
diff
changeset
|
279 bigfloat_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth), |
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4892
diff
changeset
|
280 int UNUSED (foldcase)) |
1983 | 281 { |
282 return bigfloat_eql (XBIGFLOAT_DATA (obj1), XBIGFLOAT_DATA (obj2)); | |
283 } | |
284 | |
285 static Hashcode | |
2286 | 286 bigfloat_hash (Lisp_Object obj, int UNUSED (depth)) |
1983 | 287 { |
288 return bigfloat_hashcode (XBIGFLOAT_DATA (obj)); | |
289 } | |
290 | |
291 static const struct memory_description bigfloat_description[] = { | |
292 { XD_OPAQUE_PTR, offsetof (Lisp_Bigfloat, bf) }, | |
293 { XD_END } | |
294 }; | |
295 | |
5118
e0db3c197671
merge up to latest default branch, doesn't compile yet
Ben Wing <ben@xemacs.org>
diff
changeset
|
296 DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT ("bigfloat", bigfloat, 0, |
5125 | 297 bigfloat_print, BIGFLOAT_FINALIZE, |
5124
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
298 bigfloat_equal, bigfloat_hash, |
623d57b7fbe8
separate regular and disksave finalization, print method fixes.
Ben Wing <ben@xemacs.org>
parents:
5118
diff
changeset
|
299 bigfloat_description, Lisp_Bigfloat); |
1983 | 300 |
2092 | 301 #endif /* HAVE_BIGFLOAT */ |
1983 | 302 |
303 Lisp_Object Qbigfloatp; | |
304 | |
305 DEFUN ("bigfloatp", Fbigfloatp, 1, 1, 0, /* | |
306 Return t if OBJECT is a bigfloat, nil otherwise. | |
307 */ | |
308 (object)) | |
309 { | |
310 return BIGFLOATP (object) ? Qt : Qnil; | |
311 } | |
312 | |
2092 | 313 DEFUN ("bigfloat-get-precision", Fbigfloat_get_precision, 1, 1, 0, /* |
314 Return the precision of bigfloat F as an integer. | |
315 */ | |
316 (f)) | |
317 { | |
318 CHECK_BIGFLOAT (f); | |
319 #ifdef HAVE_BIGNUM | |
320 bignum_set_ulong (scratch_bignum, XBIGFLOAT_GET_PREC (f)); | |
321 return Fcanonicalize_number (make_bignum_bg (scratch_bignum)); | |
322 #else | |
323 return make_int ((int) XBIGFLOAT_GET_PREC (f)); | |
324 #endif | |
325 } | |
326 | |
327 DEFUN ("bigfloat-set-precision", Fbigfloat_set_precision, 2, 2, 0, /* | |
328 Set the precision of F, a bigfloat, to PRECISION, a nonnegative integer. | |
329 The new precision of F is returned. Note that the return value may differ | |
330 from PRECISION if the underlying library is unable to support exactly | |
331 PRECISION bits of precision. | |
332 */ | |
333 (f, precision)) | |
334 { | |
335 unsigned long prec; | |
336 | |
337 CHECK_BIGFLOAT (f); | |
338 if (INTP (precision)) | |
339 { | |
340 prec = (XINT (precision) <= 0) ? 1UL : (unsigned long) XINT (precision); | |
341 } | |
342 #ifdef HAVE_BIGNUM | |
343 else if (BIGNUMP (precision)) | |
344 { | |
345 prec = bignum_fits_ulong_p (XBIGNUM_DATA (precision)) | |
346 ? bignum_to_ulong (XBIGNUM_DATA (precision)) | |
347 : UINT_MAX; | |
348 } | |
349 #endif | |
350 else | |
351 { | |
352 dead_wrong_type_argument (Qintegerp, f); | |
353 return Qnil; | |
354 } | |
355 | |
356 XBIGFLOAT_SET_PREC (f, prec); | |
357 return Fbigfloat_get_precision (f); | |
358 } | |
359 | |
1983 | 360 static int |
2286 | 361 default_float_precision_changed (Lisp_Object UNUSED (sym), Lisp_Object *val, |
362 Lisp_Object UNUSED (in_object), | |
363 int UNUSED (flags)) | |
1983 | 364 { |
365 unsigned long prec; | |
366 | |
367 CONCHECK_INTEGER (*val); | |
368 #ifdef HAVE_BIGFLOAT | |
369 if (INTP (*val)) | |
370 prec = XINT (*val); | |
4802
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
371 else |
1983 | 372 { |
373 if (!bignum_fits_ulong_p (XBIGNUM_DATA (*val))) | |
374 args_out_of_range_3 (*val, Qzero, Vbigfloat_max_prec); | |
375 prec = bignum_to_ulong (XBIGNUM_DATA (*val)); | |
376 } | |
377 if (prec != 0UL) | |
378 bigfloat_set_default_prec (prec); | |
379 #endif | |
380 return 0; | |
381 } | |
382 | |
383 | |
384 /********************************* Floating *********************************/ | |
385 Lisp_Object | |
386 make_floating (double d) | |
387 { | |
388 #ifdef HAVE_BIGFLOAT | |
389 if (ZEROP (Vdefault_float_precision)) | |
390 #endif | |
391 return make_float (d); | |
392 #ifdef HAVE_BIGFLOAT | |
393 else | |
394 return make_bigfloat (d, 0UL); | |
395 #endif | |
396 } | |
397 | |
398 DEFUN ("floatingp", Ffloatingp, 1, 1, 0, /* | |
399 Return t if OBJECT is a floating point number of any kind, nil otherwise. | |
400 */ | |
401 (object)) | |
402 { | |
403 return FLOATINGP (object) ? Qt : Qnil; | |
404 } | |
405 | |
406 | |
407 /********************************** Reals ***********************************/ | |
408 DEFUN ("realp", Frealp, 1, 1, 0, /* | |
409 Return t if OBJECT is a real, nil otherwise. | |
410 */ | |
411 (object)) | |
412 { | |
413 return REALP (object) ? Qt : Qnil; | |
414 } | |
415 | |
416 | |
417 /********************************* Numbers **********************************/ | |
418 DEFUN ("canonicalize-number", Fcanonicalize_number, 1, 1, 0, /* | |
419 Return the canonical form of NUMBER. | |
420 */ | |
421 (number)) | |
422 { | |
423 /* The tests should go in order from larger, more expressive, or more | |
424 complex types to smaller, less expressive, or simpler types so that a | |
425 number can cascade all the way down to the simplest type if | |
426 appropriate. */ | |
427 #ifdef HAVE_RATIO | |
428 if (RATIOP (number) && | |
429 bignum_fits_long_p (XRATIO_DENOMINATOR (number)) && | |
430 bignum_to_long (XRATIO_DENOMINATOR (number)) == 1L) | |
4883
f730384b8ddf
Be more careful about canonical integer forms when dealing with ratios.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4802
diff
changeset
|
431 number = Fcanonicalize_number (make_bignum_bg (XRATIO_NUMERATOR (number))); |
1983 | 432 #endif |
433 #ifdef HAVE_BIGNUM | |
3391 | 434 if (BIGNUMP (number) && bignum_fits_emacs_int_p (XBIGNUM_DATA (number))) |
1983 | 435 { |
3391 | 436 EMACS_INT n = bignum_to_emacs_int (XBIGNUM_DATA (number)); |
1983 | 437 if (NUMBER_FITS_IN_AN_EMACS_INT (n)) |
438 number = make_int (n); | |
439 } | |
440 #endif | |
441 return number; | |
442 } | |
443 | |
444 enum number_type | |
445 get_number_type (Lisp_Object arg) | |
446 { | |
447 if (INTP (arg)) | |
448 return FIXNUM_T; | |
449 #ifdef HAVE_BIGNUM | |
450 if (BIGNUMP (arg)) | |
451 return BIGNUM_T; | |
452 #endif | |
453 #ifdef HAVE_RATIO | |
454 if (RATIOP (arg)) | |
455 return RATIO_T; | |
456 #endif | |
457 if (FLOATP (arg)) | |
458 return FLOAT_T; | |
459 #ifdef HAVE_BIGFLOAT | |
460 if (BIGFLOATP (arg)) | |
461 return BIGFLOAT_T; | |
462 #endif | |
463 /* Catch unintentional bad uses of this function */ | |
2500 | 464 ABORT (); |
1995 | 465 /* NOTREACHED */ |
466 return FIXNUM_T; | |
1983 | 467 } |
468 | |
469 /* Convert NUMBER to type TYPE. If TYPE is BIGFLOAT_T then use the indicated | |
470 PRECISION; otherwise, PRECISION is ignored. */ | |
471 static Lisp_Object | |
472 internal_coerce_number (Lisp_Object number, enum number_type type, | |
2286 | 473 #ifdef HAVE_BIGFLOAT |
474 unsigned long precision | |
475 #else | |
476 unsigned long UNUSED (precision) | |
477 #endif | |
478 ) | |
1983 | 479 { |
480 enum number_type current_type; | |
481 | |
482 if (CHARP (number)) | |
483 number = make_int (XCHAR (number)); | |
484 else if (MARKERP (number)) | |
485 number = make_int (marker_position (number)); | |
486 | |
487 /* Note that CHECK_NUMBER ensures that NUMBER is a supported type. Hence, | |
2500 | 488 we ABORT() in the #else sections below, because it shouldn't be possible |
1983 | 489 to arrive there. */ |
490 CHECK_NUMBER (number); | |
491 current_type = get_number_type (number); | |
492 switch (current_type) | |
493 { | |
494 case FIXNUM_T: | |
495 switch (type) | |
496 { | |
497 case FIXNUM_T: | |
498 return number; | |
499 case BIGNUM_T: | |
500 #ifdef HAVE_BIGNUM | |
501 return make_bignum (XREALINT (number)); | |
502 #else | |
2500 | 503 ABORT (); |
1983 | 504 #endif /* HAVE_BIGNUM */ |
505 case RATIO_T: | |
506 #ifdef HAVE_RATIO | |
507 return make_ratio (XREALINT (number), 1UL); | |
508 #else | |
2500 | 509 ABORT (); |
1983 | 510 #endif /* HAVE_RATIO */ |
511 case FLOAT_T: | |
512 return make_float (XREALINT (number)); | |
513 case BIGFLOAT_T: | |
514 #ifdef HAVE_BIGFLOAT | |
515 return make_bigfloat (XREALINT (number), precision); | |
516 #else | |
2500 | 517 ABORT (); |
1983 | 518 #endif /* HAVE_BIGFLOAT */ |
519 } | |
520 case BIGNUM_T: | |
521 #ifdef HAVE_BIGNUM | |
522 switch (type) | |
523 { | |
524 case FIXNUM_T: | |
525 return make_int (bignum_to_long (XBIGNUM_DATA (number))); | |
526 case BIGNUM_T: | |
527 return number; | |
528 case RATIO_T: | |
529 #ifdef HAVE_RATIO | |
530 bignum_set_long (scratch_bignum, 1L); | |
531 return make_ratio_bg (XBIGNUM_DATA (number), scratch_bignum); | |
532 #else | |
2500 | 533 ABORT (); |
1983 | 534 #endif /* HAVE_RATIO */ |
535 case FLOAT_T: | |
536 return make_float (bignum_to_double (XBIGNUM_DATA (number))); | |
537 case BIGFLOAT_T: | |
538 #ifdef HAVE_BIGFLOAT | |
539 { | |
540 Lisp_Object temp; | |
541 temp = make_bigfloat (0.0, precision); | |
542 bigfloat_set_bignum (XBIGFLOAT_DATA (temp), XBIGNUM_DATA (number)); | |
543 return temp; | |
544 } | |
545 #else | |
2500 | 546 ABORT (); |
1983 | 547 #endif /* HAVE_BIGFLOAT */ |
548 } | |
549 #else | |
2500 | 550 ABORT (); |
1983 | 551 #endif /* HAVE_BIGNUM */ |
552 case RATIO_T: | |
553 #ifdef HAVE_RATIO | |
554 switch (type) | |
555 { | |
556 case FIXNUM_T: | |
557 bignum_div (scratch_bignum, XRATIO_NUMERATOR (number), | |
558 XRATIO_DENOMINATOR (number)); | |
559 return make_int (bignum_to_long (scratch_bignum)); | |
560 case BIGNUM_T: | |
561 bignum_div (scratch_bignum, XRATIO_NUMERATOR (number), | |
562 XRATIO_DENOMINATOR (number)); | |
563 return make_bignum_bg (scratch_bignum); | |
564 case RATIO_T: | |
565 return number; | |
566 case FLOAT_T: | |
567 return make_float (ratio_to_double (XRATIO_DATA (number))); | |
568 case BIGFLOAT_T: | |
569 #ifdef HAVE_BIGFLOAT | |
570 { | |
571 Lisp_Object temp; | |
572 temp = make_bigfloat (0.0, precision); | |
573 bigfloat_set_ratio (XBIGFLOAT_DATA (temp), XRATIO_DATA (number)); | |
574 return temp; | |
575 } | |
576 #else | |
2500 | 577 ABORT (); |
1983 | 578 #endif /* HAVE_BIGFLOAT */ |
579 } | |
580 #else | |
2500 | 581 ABORT (); |
1983 | 582 #endif /* HAVE_RATIO */ |
583 case FLOAT_T: | |
584 switch (type) | |
585 { | |
586 case FIXNUM_T: | |
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3391
diff
changeset
|
587 return Ftruncate (number, Qnil); |
1983 | 588 case BIGNUM_T: |
589 #ifdef HAVE_BIGNUM | |
590 bignum_set_double (scratch_bignum, XFLOAT_DATA (number)); | |
591 return make_bignum_bg (scratch_bignum); | |
592 #else | |
2500 | 593 ABORT (); |
1983 | 594 #endif /* HAVE_BIGNUM */ |
595 case RATIO_T: | |
596 #ifdef HAVE_RATIO | |
597 ratio_set_double (scratch_ratio, XFLOAT_DATA (number)); | |
598 return make_ratio_rt (scratch_ratio); | |
599 #else | |
2500 | 600 ABORT (); |
1983 | 601 #endif /* HAVE_RATIO */ |
602 case FLOAT_T: | |
603 return number; | |
604 case BIGFLOAT_T: | |
605 #ifdef HAVE_BIGFLOAT | |
606 bigfloat_set_prec (scratch_bigfloat, precision); | |
607 bigfloat_set_double (scratch_bigfloat, XFLOAT_DATA (number)); | |
608 return make_bigfloat_bf (scratch_bigfloat); | |
609 #else | |
2500 | 610 ABORT (); |
1983 | 611 #endif /* HAVE_BIGFLOAT */ |
612 } | |
613 case BIGFLOAT_T: | |
614 #ifdef HAVE_BIGFLOAT | |
615 switch (type) | |
616 { | |
617 case FIXNUM_T: | |
618 return make_int (bigfloat_to_long (XBIGFLOAT_DATA (number))); | |
619 case BIGNUM_T: | |
620 #ifdef HAVE_BIGNUM | |
621 bignum_set_bigfloat (scratch_bignum, XBIGFLOAT_DATA (number)); | |
622 return make_bignum_bg (scratch_bignum); | |
623 #else | |
2500 | 624 ABORT (); |
1983 | 625 #endif /* HAVE_BIGNUM */ |
626 case RATIO_T: | |
627 #ifdef HAVE_RATIO | |
628 ratio_set_bigfloat (scratch_ratio, XBIGFLOAT_DATA (number)); | |
629 return make_ratio_rt (scratch_ratio); | |
630 #else | |
2500 | 631 ABORT (); |
1983 | 632 #endif |
633 case FLOAT_T: | |
634 return make_float (bigfloat_to_double (XBIGFLOAT_DATA (number))); | |
635 case BIGFLOAT_T: | |
636 /* FIXME: Do we need to change the precision? */ | |
637 return number; | |
638 } | |
639 #else | |
2500 | 640 ABORT (); |
1983 | 641 #endif /* HAVE_BIGFLOAT */ |
642 } | |
2500 | 643 ABORT (); |
1995 | 644 /* NOTREACHED */ |
645 return Qzero; | |
1983 | 646 } |
647 | |
648 /* This function promotes its arguments as necessary to make them both the | |
649 same type. It destructively modifies its arguments to do so. Characters | |
650 and markers are ALWAYS converted to integers. */ | |
651 enum number_type | |
652 promote_args (Lisp_Object *arg1, Lisp_Object *arg2) | |
653 { | |
654 enum number_type type1, type2; | |
655 | |
656 if (CHARP (*arg1)) | |
657 *arg1 = make_int (XCHAR (*arg1)); | |
658 else if (MARKERP (*arg1)) | |
659 *arg1 = make_int (marker_position (*arg1)); | |
660 if (CHARP (*arg2)) | |
661 *arg2 = make_int (XCHAR (*arg2)); | |
662 else if (MARKERP (*arg2)) | |
663 *arg2 = make_int (marker_position (*arg2)); | |
664 | |
665 CHECK_NUMBER (*arg1); | |
666 CHECK_NUMBER (*arg2); | |
667 | |
668 type1 = get_number_type (*arg1); | |
669 type2 = get_number_type (*arg2); | |
670 | |
671 if (type1 < type2) | |
672 { | |
673 *arg1 = internal_coerce_number (*arg1, type2, | |
674 #ifdef HAVE_BIGFLOAT | |
675 type2 == BIGFLOAT_T | |
676 ? XBIGFLOAT_GET_PREC (*arg2) : | |
677 #endif | |
678 0UL); | |
679 return type2; | |
680 } | |
4802
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
681 |
1983 | 682 if (type2 < type1) |
683 { | |
684 *arg2 = internal_coerce_number (*arg2, type1, | |
685 #ifdef HAVE_BIGFLOAT | |
686 type1 == BIGFLOAT_T | |
687 ? XBIGFLOAT_GET_PREC (*arg1) : | |
688 #endif | |
689 0UL); | |
690 return type1; | |
691 } | |
692 | |
693 /* No conversion necessary */ | |
694 return type1; | |
695 } | |
696 | |
697 DEFUN ("coerce-number", Fcoerce_number, 2, 3, 0, /* | |
698 Convert NUMBER to the indicated type, possibly losing information. | |
699 Do not call this function. Use `coerce' instead. | |
700 | |
3025 | 701 TYPE is one of the symbols `fixnum', `integer', `ratio', `float', or |
702 `bigfloat'. Not all of these types may be supported. | |
1983 | 703 |
704 PRECISION is the number of bits of precision to use when converting to | |
705 bigfloat; it is ignored otherwise. If nil, the default precision is used. | |
706 | |
707 Note that some conversions lose information. No error is signaled in such | |
708 cases; the information is silently lost. | |
709 */ | |
2595 | 710 (number, type, USED_IF_BIGFLOAT (precision))) |
1983 | 711 { |
712 CHECK_SYMBOL (type); | |
713 if (EQ (type, Qfixnum)) | |
714 return internal_coerce_number (number, FIXNUM_T, 0UL); | |
715 else if (EQ (type, Qinteger)) | |
716 { | |
717 /* If bignums are available, we always convert to one first, then | |
718 downgrade to a fixnum if possible. */ | |
719 #ifdef HAVE_BIGNUM | |
720 return Fcanonicalize_number | |
721 (internal_coerce_number (number, BIGNUM_T, 0UL)); | |
722 #else | |
723 return internal_coerce_number (number, FIXNUM_T, 0UL); | |
724 #endif | |
725 } | |
726 #ifdef HAVE_RATIO | |
727 else if (EQ (type, Qratio)) | |
728 return internal_coerce_number (number, RATIO_T, 0UL); | |
729 #endif | |
730 else if (EQ (type, Qfloat)) | |
731 return internal_coerce_number (number, FLOAT_T, 0UL); | |
732 #ifdef HAVE_BIGFLOAT | |
733 else if (EQ (type, Qbigfloat)) | |
734 { | |
735 unsigned long prec; | |
736 | |
737 if (NILP (precision)) | |
738 prec = bigfloat_get_default_prec (); | |
739 else | |
740 { | |
741 CHECK_INTEGER (precision); | |
742 #ifdef HAVE_BIGNUM | |
743 if (INTP (precision)) | |
744 #endif /* HAVE_BIGNUM */ | |
745 prec = (unsigned long) XREALINT (precision); | |
746 #ifdef HAVE_BIGNUM | |
747 else | |
748 { | |
749 if (!bignum_fits_ulong_p (XBIGNUM_DATA (precision))) | |
750 args_out_of_range (precision, Vbigfloat_max_prec); | |
751 prec = bignum_to_ulong (XBIGNUM_DATA (precision)); | |
752 } | |
753 #endif /* HAVE_BIGNUM */ | |
754 } | |
755 return internal_coerce_number (number, BIGFLOAT_T, prec); | |
756 } | |
757 #endif /* HAVE_BIGFLOAT */ | |
758 | |
759 Fsignal (Qunsupported_type, type); | |
760 /* NOTREACHED */ | |
761 return Qnil; | |
762 } | |
763 | |
764 | |
765 void | |
766 syms_of_number (void) | |
767 { | |
768 #ifdef HAVE_BIGNUM | |
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
769 INIT_LISP_OBJECT (bignum); |
1983 | 770 #endif |
771 #ifdef HAVE_RATIO | |
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
772 INIT_LISP_OBJECT (ratio); |
1983 | 773 #endif |
774 #ifdef HAVE_BIGFLOAT | |
5117
3742ea8250b5
Checking in final CVS version of workspace 'ben-lisp-object'
Ben Wing <ben@xemacs.org>
parents:
3025
diff
changeset
|
775 INIT_LISP_OBJECT (bigfloat); |
1983 | 776 #endif |
777 | |
778 /* Type predicates */ | |
779 DEFSYMBOL (Qrationalp); | |
780 DEFSYMBOL (Qfloatingp); | |
781 DEFSYMBOL (Qrealp); | |
782 DEFSYMBOL (Qbignump); | |
783 DEFSYMBOL (Qratiop); | |
784 DEFSYMBOL (Qbigfloatp); | |
785 | |
786 /* Functions */ | |
787 DEFSUBR (Fbignump); | |
788 DEFSUBR (Fratiop); | |
789 DEFSUBR (Frationalp); | |
790 DEFSUBR (Fnumerator); | |
791 DEFSUBR (Fdenominator); | |
792 DEFSUBR (Fbigfloatp); | |
2092 | 793 DEFSUBR (Fbigfloat_get_precision); |
794 DEFSUBR (Fbigfloat_set_precision); | |
2001 | 795 DEFSUBR (Ffloatingp); |
1983 | 796 DEFSUBR (Frealp); |
797 DEFSUBR (Fcanonicalize_number); | |
798 DEFSUBR (Fcoerce_number); | |
799 | |
800 /* Errors */ | |
801 DEFERROR_STANDARD (Qunsupported_type, Qwrong_type_argument); | |
802 } | |
803 | |
804 void | |
805 vars_of_number (void) | |
806 { | |
2051 | 807 /* These variables are Lisp variables rather than number variables so that |
808 we can put bignums in them. */ | |
1983 | 809 DEFVAR_LISP_MAGIC ("default-float-precision", &Vdefault_float_precision, /* |
810 The default floating-point precision for newly created floating point values. | |
2092 | 811 This should be 0 to create Lisp float types, or an unsigned integer no greater |
812 than `bigfloat-maximum-precision' to create Lisp bigfloat types with the | |
813 indicated precision. | |
1983 | 814 */ default_float_precision_changed); |
815 Vdefault_float_precision = make_int (0); | |
816 | |
2092 | 817 DEFVAR_CONST_LISP ("bigfloat-maximum-precision", &Vbigfloat_max_prec /* |
1983 | 818 The maximum number of bits of precision a bigfloat can have. |
2092 | 819 This is determined by the underlying library used to implement bigfloats. |
1983 | 820 */); |
821 | |
2061 | 822 #ifdef HAVE_BIGFLOAT |
4802
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
823 /* Don't create a bignum here. Otherwise, we lose with NEW_GC + pdump. |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
824 See reinit_vars_of_number(). */ |
2061 | 825 Vbigfloat_max_prec = make_int (EMACS_INT_MAX); |
826 #else | |
2051 | 827 Vbigfloat_max_prec = make_int (0); |
828 #endif /* HAVE_BIGFLOAT */ | |
829 | |
1983 | 830 Fprovide (intern ("number-types")); |
831 #ifdef HAVE_BIGNUM | |
832 Fprovide (intern ("bignum")); | |
833 #endif | |
834 #ifdef HAVE_RATIO | |
835 Fprovide (intern ("ratio")); | |
836 #endif | |
837 #ifdef HAVE_BIGFLOAT | |
838 Fprovide (intern ("bigfloat")); | |
839 #endif | |
840 } | |
841 | |
842 void | |
4802
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
843 reinit_vars_of_number (void) |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
844 { |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
845 #if defined(HAVE_BIGFLOAT) && defined(HAVE_BIGNUM) |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
846 Vbigfloat_max_prec = make_bignum (0L); |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
847 bignum_set_ulong (XBIGNUM_DATA (Vbigfloat_max_prec), ULONG_MAX); |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
848 #endif |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
849 } |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
850 |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
851 void |
1983 | 852 init_number (void) |
853 { | |
854 if (!number_initialized) | |
855 { | |
856 number_initialized = 1; | |
857 | |
858 #ifdef WITH_GMP | |
859 init_number_gmp (); | |
860 #endif | |
861 #ifdef WITH_MP | |
862 init_number_mp (); | |
863 #endif | |
864 | |
865 #ifdef HAVE_BIGNUM | |
866 bignum_init (scratch_bignum); | |
867 bignum_init (scratch_bignum2); | |
868 #endif | |
869 | |
870 #ifdef HAVE_RATIO | |
871 ratio_init (scratch_ratio); | |
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3391
diff
changeset
|
872 ratio_init (scratch_ratio2); |
1983 | 873 #endif |
874 | |
875 #ifdef HAVE_BIGFLOAT | |
876 bigfloat_init (scratch_bigfloat); | |
877 bigfloat_init (scratch_bigfloat2); | |
878 #endif | |
4802
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
879 |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
880 #ifndef PDUMP |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
881 reinit_vars_of_number (); |
2fc0e2f18322
Don't create any bignums before pdumping. Add bignum, ratio, and bigfloat
Jerry James <james@xemacs.org>
parents:
4678
diff
changeset
|
882 #endif |
1983 | 883 } |
884 } |