Mercurial > hg > xemacs-beta
annotate tests/automated/lisp-tests.el @ 4981:4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
-------------------- ChangeLog entries follow: --------------------
modules/ChangeLog addition:
2010-02-05 Ben Wing <ben@xemacs.org>
* postgresql/postgresql.c:
* postgresql/postgresql.c (CHECK_LIVE_CONNECTION):
* postgresql/postgresql.c (Fpq_connectdb):
* postgresql/postgresql.c (Fpq_connect_start):
* postgresql/postgresql.c (Fpq_lo_import):
* postgresql/postgresql.c (Fpq_lo_export):
* ldap/eldap.c (Fldap_open):
* ldap/eldap.c (Fldap_search_basic):
* ldap/eldap.c (Fldap_add):
* ldap/eldap.c (Fldap_modify):
* ldap/eldap.c (Fldap_delete):
* canna/canna_api.c (Fcanna_initialize):
* canna/canna_api.c (Fcanna_store_yomi):
* canna/canna_api.c (Fcanna_parse):
* canna/canna_api.c (Fcanna_henkan_begin):
EXTERNAL_TO_C_STRING returns its argument instead of storing it
in a parameter, and is renamed to EXTERNAL_TO_ITEXT. Similar
things happen to related macros. See entry in src/ChangeLog.
More Mule-izing of postgresql.c. Extract out common code
between `pq-connectdb' and `pq-connect-start'. Fix places
that signal an error string using a formatted string to instead
follow the standard and have a fixed reason followed by the
particular error message stored as one of the frobs.
src/ChangeLog addition:
2010-02-05 Ben Wing <ben@xemacs.org>
* console-msw.c (write_string_to_mswindows_debugging_output):
* console-msw.c (Fmswindows_message_box):
* console-x.c (x_perhaps_init_unseen_key_defaults):
* console.c:
* database.c (dbm_get):
* database.c (dbm_put):
* database.c (dbm_remove):
* database.c (berkdb_get):
* database.c (berkdb_put):
* database.c (berkdb_remove):
* database.c (Fopen_database):
* device-gtk.c (gtk_init_device):
* device-msw.c (msprinter_init_device_internal):
* device-msw.c (msprinter_default_printer):
* device-msw.c (msprinter_init_device):
* device-msw.c (sync_printer_with_devmode):
* device-msw.c (Fmsprinter_select_settings):
* device-x.c (sanity_check_geometry_resource):
* device-x.c (Dynarr_add_validified_lisp_string):
* device-x.c (x_init_device):
* device-x.c (Fx_put_resource):
* device-x.c (Fx_valid_keysym_name_p):
* device-x.c (Fx_set_font_path):
* dialog-msw.c (push_lisp_string_as_unicode):
* dialog-msw.c (handle_directory_dialog_box):
* dialog-msw.c (handle_file_dialog_box):
* dialog-x.c (dbox_descriptor_to_widget_value):
* editfns.c (Fformat_time_string):
* editfns.c (Fencode_time):
* editfns.c (Fset_time_zone_rule):
* emacs.c (make_argc_argv):
* emacs.c (Fdump_emacs):
* emodules.c (emodules_load):
* eval.c:
* eval.c (maybe_signal_error_1):
* event-msw.c (Fdde_alloc_advise_item):
* event-msw.c (mswindows_dde_callback):
* event-msw.c (mswindows_wnd_proc):
* fileio.c (report_error_with_errno):
* fileio.c (Fsysnetunam):
* fileio.c (Fdo_auto_save):
* font-mgr.c (extract_fcapi_string):
* font-mgr.c (Ffc_config_app_font_add_file):
* font-mgr.c (Ffc_config_app_font_add_dir):
* font-mgr.c (Ffc_config_filename):
* frame-gtk.c (gtk_set_frame_text_value):
* frame-gtk.c (gtk_create_widgets):
* frame-msw.c (mswindows_init_frame_1):
* frame-msw.c (mswindows_set_title_from_ibyte):
* frame-msw.c (msprinter_init_frame_3):
* frame-x.c (x_set_frame_text_value):
* frame-x.c (x_set_frame_properties):
* frame-x.c (start_drag_internal_1):
* frame-x.c (x_cde_transfer_callback):
* frame-x.c (x_create_widgets):
* glyphs-eimage.c (my_jpeg_output_message):
* glyphs-eimage.c (jpeg_instantiate):
* glyphs-eimage.c (gif_instantiate):
* glyphs-eimage.c (png_instantiate):
* glyphs-eimage.c (tiff_instantiate):
* glyphs-gtk.c (xbm_instantiate_1):
* glyphs-gtk.c (gtk_xbm_instantiate):
* glyphs-gtk.c (gtk_xpm_instantiate):
* glyphs-gtk.c (gtk_xface_instantiate):
* glyphs-gtk.c (cursor_font_instantiate):
* glyphs-gtk.c (gtk_redisplay_widget):
* glyphs-gtk.c (gtk_widget_instantiate_1):
* glyphs-gtk.c (gtk_add_tab_item):
* glyphs-msw.c (mswindows_xpm_instantiate):
* glyphs-msw.c (bmp_instantiate):
* glyphs-msw.c (mswindows_resource_instantiate):
* glyphs-msw.c (xbm_instantiate_1):
* glyphs-msw.c (mswindows_xbm_instantiate):
* glyphs-msw.c (mswindows_xface_instantiate):
* glyphs-msw.c (mswindows_redisplay_widget):
* glyphs-msw.c (mswindows_widget_instantiate):
* glyphs-msw.c (add_tree_item):
* glyphs-msw.c (add_tab_item):
* glyphs-msw.c (mswindows_combo_box_instantiate):
* glyphs-msw.c (mswindows_widget_query_string_geometry):
* glyphs-x.c (x_locate_pixmap_file):
* glyphs-x.c (xbm_instantiate_1):
* glyphs-x.c (x_xbm_instantiate):
* glyphs-x.c (extract_xpm_color_names):
* glyphs-x.c (x_xpm_instantiate):
* glyphs-x.c (x_xface_instantiate):
* glyphs-x.c (autodetect_instantiate):
* glyphs-x.c (safe_XLoadFont):
* glyphs-x.c (cursor_font_instantiate):
* glyphs-x.c (x_redisplay_widget):
* glyphs-x.c (Fchange_subwindow_property):
* glyphs-x.c (x_widget_instantiate):
* glyphs-x.c (x_tab_control_redisplay):
* glyphs.c (pixmap_to_lisp_data):
* gui-x.c (menu_separator_style_and_to_external):
* gui-x.c (add_accel_and_to_external):
* gui-x.c (button_item_to_widget_value):
* hpplay.c (player_error_internal):
* hpplay.c (play_sound_file):
* hpplay.c (play_sound_data):
* intl.c (Fset_current_locale):
* lisp.h:
* menubar-gtk.c (gtk_xemacs_set_accel_keys):
* menubar-msw.c (populate_menu_add_item):
* menubar-msw.c (populate_or_checksum_helper):
* menubar-x.c (menu_item_descriptor_to_widget_value_1):
* nt.c (init_user_info):
* nt.c (get_long_basename):
* nt.c (nt_get_resource):
* nt.c (init_mswindows_environment):
* nt.c (get_cached_volume_information):
* nt.c (mswindows_readdir):
* nt.c (read_unc_volume):
* nt.c (mswindows_stat):
* nt.c (mswindows_getdcwd):
* nt.c (mswindows_executable_type):
* nt.c (Fmswindows_short_file_name):
* ntplay.c (nt_play_sound_file):
* objects-gtk.c:
* objects-gtk.c (gtk_valid_color_name_p):
* objects-gtk.c (gtk_initialize_font_instance):
* objects-gtk.c (gtk_font_list):
* objects-msw.c (font_enum_callback_2):
* objects-msw.c (parse_font_spec):
* objects-x.c (x_parse_nearest_color):
* objects-x.c (x_valid_color_name_p):
* objects-x.c (x_initialize_font_instance):
* objects-x.c (x_font_instance_truename):
* objects-x.c (x_font_list):
* objects-xlike-inc.c (XFUN):
* objects-xlike-inc.c (xft_find_charset_font):
* process-nt.c (mswindows_report_winsock_error):
* process-nt.c (nt_create_process):
* process-nt.c (get_internet_address):
* process-nt.c (nt_open_network_stream):
* process-unix.c:
* process-unix.c (allocate_pty):
* process-unix.c (get_internet_address):
* process-unix.c (unix_canonicalize_host_name):
* process-unix.c (unix_open_network_stream):
* realpath.c:
* select-common.h (lisp_data_to_selection_data):
* select-gtk.c (symbol_to_gtk_atom):
* select-gtk.c (atom_to_symbol):
* select-msw.c (symbol_to_ms_cf):
* select-msw.c (mswindows_register_selection_data_type):
* select-x.c (symbol_to_x_atom):
* select-x.c (x_atom_to_symbol):
* select-x.c (hack_motif_clipboard_selection):
* select-x.c (Fx_store_cutbuffer_internal):
* sound.c (Fplay_sound_file):
* sound.c (Fplay_sound):
* sound.h (sound_perror):
* sysdep.c:
* sysdep.c (qxe_allocating_getcwd):
* sysdep.c (qxe_execve):
* sysdep.c (copy_in_passwd):
* sysdep.c (qxe_getpwnam):
* sysdep.c (qxe_ctime):
* sysdll.c (dll_open):
* sysdll.c (dll_function):
* sysdll.c (dll_variable):
* sysdll.c (search_linked_libs):
* sysdll.c (dll_error):
* sysfile.h:
* sysfile.h (PATHNAME_CONVERT_OUT_TSTR):
* sysfile.h (PATHNAME_CONVERT_OUT_UTF_8):
* sysfile.h (PATHNAME_CONVERT_OUT):
* sysfile.h (LISP_PATHNAME_CONVERT_OUT):
* syswindows.h (ITEXT_TO_TSTR):
* syswindows.h (LOCAL_FILE_FORMAT_TO_TSTR):
* syswindows.h (TSTR_TO_LOCAL_FILE_FORMAT):
* syswindows.h (LOCAL_FILE_FORMAT_TO_INTERNAL_MSWIN):
* syswindows.h (LISP_LOCAL_FILE_FORMAT_MAYBE_URL_TO_TSTR):
* text.h:
* text.h (eicpy_ext_len):
* text.h (enum new_dfc_src_type):
* text.h (EXTERNAL_TO_ITEXT):
* text.h (GET_STRERROR):
* tooltalk.c (check_status):
* tooltalk.c (Fadd_tooltalk_message_arg):
* tooltalk.c (Fadd_tooltalk_pattern_attribute):
* tooltalk.c (Fadd_tooltalk_pattern_arg):
* win32.c (tstr_to_local_file_format):
* win32.c (mswindows_lisp_error_1):
* win32.c (mswindows_report_process_error):
* win32.c (Fmswindows_shell_execute):
* win32.c (mswindows_read_link_1):
Changes involving external/internal format conversion,
mostly code cleanup and renaming.
1. Eliminate the previous macros like LISP_STRING_TO_EXTERNAL
that stored its result in a parameter. The new version of
LISP_STRING_TO_EXTERNAL returns its result through the
return value, same as the previous NEW_LISP_STRING_TO_EXTERNAL.
Use the new-style macros throughout the code.
2. Rename C_STRING_TO_EXTERNAL and friends to ITEXT_TO_EXTERNAL,
in keeping with overall naming rationalization involving
Itext and related types.
Macros involved in previous two:
EXTERNAL_TO_C_STRING -> EXTERNAL_TO_ITEXT
EXTERNAL_TO_C_STRING_MALLOC -> EXTERNAL_TO_ITEXT_MALLOC
SIZED_EXTERNAL_TO_C_STRING -> SIZED_EXTERNAL_TO_ITEXT
SIZED_EXTERNAL_TO_C_STRING_MALLOC -> SIZED_EXTERNAL_TO_ITEXT_MALLOC
C_STRING_TO_EXTERNAL -> ITEXT_TO_EXTERNAL
C_STRING_TO_EXTERNAL_MALLOC -> ITEXT_TO_EXTERNAL_MALLOC
LISP_STRING_TO_EXTERNAL
LISP_STRING_TO_EXTERNAL_MALLOC
LISP_STRING_TO_TSTR
C_STRING_TO_TSTR -> ITEXT_TO_TSTR
TSTR_TO_C_STRING -> TSTR_TO_ITEXT
The following four still return their values through parameters,
since they have more than one value to return:
C_STRING_TO_SIZED_EXTERNAL -> ITEXT_TO_SIZED_EXTERNAL
LISP_STRING_TO_SIZED_EXTERNAL
C_STRING_TO_SIZED_EXTERNAL_MALLOC -> ITEXT_TO_SIZED_EXTERNAL_MALLOC
LISP_STRING_TO_SIZED_EXTERNAL_MALLOC
Sometimes additional casts had to be inserted, since the old
macros played strange games and completely defeated the type system
of the store params.
3. Rewrite many places where direct calls to TO_EXTERNAL_FORMAT
occurred with calls to one of the convenience macros listed above,
or to make_extstring().
4. Eliminate SIZED_C_STRING macros (they were hardly used, anyway)
and use a direct call to TO_EXTERNAL_FORMAT or TO_INTERNAL_FORMAT.
4. Use LISP_PATHNAME_CONVERT_OUT in many places instead of something
like LISP_STRING_TO_EXTERNAL(..., Qfile_name).
5. Eliminate some temporary variables that are no longer necessary
now that we return a value rather than storing it into a variable.
6. Some Mule-izing in database.c.
7. Error functions:
-- A bit of code cleanup in maybe_signal_error_1.
-- Eliminate report_file_type_error; it's just an alias for
signal_error_2 with params in a different order.
-- Fix some places in the hostname-handling code that directly
inserted externally-retrieved error strings into the
supposed ASCII "reason" param instead of doing the right thing
and sticking text descriptive of what was going on in "reason"
and putting the external message in a frob.
8. Use Ascbyte instead of CIbyte in process-unix.c and maybe one
or two other places.
9. Some code cleanup in copy_in_passwd() in sysdep.c.
10. Fix a real bug due to accidental variable shadowing in
tstr_to_local_file_format() in win32.c.
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Fri, 05 Feb 2010 11:02:24 -0600 |
| parents | 6ef8256a020a |
| children | 1b96882bdf37 |
| rev | line source |
|---|---|
| 428 | 1 ;; Copyright (C) 1998 Free Software Foundation, Inc. |
| 2 | |
| 3 ;; Author: Martin Buchholz <martin@xemacs.org> | |
| 4 ;; Maintainer: Martin Buchholz <martin@xemacs.org> | |
| 5 ;; Created: 1998 | |
| 6 ;; Keywords: tests | |
| 7 | |
| 8 ;; This file is part of XEmacs. | |
| 9 | |
| 10 ;; XEmacs is free software; you can redistribute it and/or modify it | |
| 11 ;; under the terms of the GNU General Public License as published by | |
| 12 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 13 ;; any later version. | |
| 14 | |
| 15 ;; XEmacs is distributed in the hope that it will be useful, but | |
| 16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
| 18 ;; General Public License for more details. | |
| 19 | |
| 20 ;; You should have received a copy of the GNU General Public License | |
| 21 ;; along with XEmacs; see the file COPYING. If not, write to the Free | |
| 22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA | |
| 23 ;; 02111-1307, USA. | |
| 24 | |
| 25 ;;; Synched up with: Not in FSF. | |
| 26 | |
| 27 ;;; Commentary: | |
| 28 | |
| 29 ;;; Test basic Lisp engine functionality | |
| 30 ;;; See test-harness.el for instructions on how to run these tests. | |
| 31 | |
| 32 (eval-when-compile | |
| 33 (condition-case nil | |
| 34 (require 'test-harness) | |
| 35 (file-error | |
| 36 (push "." load-path) | |
| 37 (when (and (boundp 'load-file-name) (stringp load-file-name)) | |
| 38 (push (file-name-directory load-file-name) load-path)) | |
| 39 (require 'test-harness)))) | |
| 40 | |
| 41 (Check-Error wrong-number-of-arguments (setq setq-test-foo)) | |
| 42 (Check-Error wrong-number-of-arguments (setq setq-test-foo 1 setq-test-bar)) | |
| 43 (Check-Error wrong-number-of-arguments (setq-default setq-test-foo)) | |
| 44 (Check-Error wrong-number-of-arguments (setq-default setq-test-foo 1 setq-test-bar)) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
45 (Assert-eq (setq) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
46 (Assert-eq (setq-default) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
47 (Assert-eq (setq setq-test-foo 42) 42) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
48 (Assert-eq (setq-default setq-test-foo 42) 42) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
49 (Assert-eq (setq setq-test-foo 42 setq-test-bar 99) 99) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
50 (Assert-eq (setq-default setq-test-foo 42 setq-test-bar 99) 99) |
| 428 | 51 |
| 52 (macrolet ((test-setq (expected-result &rest body) | |
| 53 `(progn | |
| 54 (defun test-setq-fun () ,@body) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
55 (Assert-eq ,expected-result (test-setq-fun)) |
| 428 | 56 (byte-compile 'test-setq-fun) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
57 (Assert-eq ,expected-result (test-setq-fun))))) |
| 428 | 58 (test-setq nil (setq)) |
| 59 (test-setq nil (setq-default)) | |
| 60 (test-setq 42 (setq test-setq-var 42)) | |
| 61 (test-setq 42 (setq-default test-setq-var 42)) | |
| 62 (test-setq 42 (setq test-setq-bar 99 test-setq-var 42)) | |
| 63 (test-setq 42 (setq-default test-setq-bar 99 test-setq-var 42)) | |
| 64 ) | |
| 65 | |
| 66 (let ((my-vector [1 2 3 4]) | |
| 67 (my-bit-vector (bit-vector 1 0 1 0)) | |
| 68 (my-string "1234") | |
| 69 (my-list '(1 2 3 4))) | |
| 70 | |
| 71 ;;(Assert (fooooo)) ;; Generate Other failure | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
72 ;;(Assert-eq 1 2) ;; Generate Assertion failure |
| 428 | 73 |
| 74 (dolist (sequence (list my-vector my-bit-vector my-string my-list)) | |
| 75 (Assert (sequencep sequence)) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
76 (Assert-eq 4 (length sequence))) |
| 428 | 77 |
| 78 (dolist (array (list my-vector my-bit-vector my-string)) | |
| 79 (Assert (arrayp array))) | |
| 80 | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
81 (Assert-eq (elt my-vector 0) 1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
82 (Assert-eq (elt my-bit-vector 0) 1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
83 (Assert-eq (elt my-string 0) ?1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
84 (Assert-eq (elt my-list 0) 1) |
| 428 | 85 |
| 86 (fillarray my-vector 5) | |
| 87 (fillarray my-bit-vector 1) | |
| 88 (fillarray my-string ?5) | |
| 89 | |
| 90 (dolist (array (list my-vector my-bit-vector)) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
91 (Assert-eq 4 (length array))) |
| 428 | 92 |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
93 (Assert-eq (elt my-vector 0) 5) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
94 (Assert-eq (elt my-bit-vector 0) 1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
95 (Assert-eq (elt my-string 0) ?5) |
| 428 | 96 |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
97 (Assert-eq (elt my-vector 3) 5) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
98 (Assert-eq (elt my-bit-vector 3) 1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
99 (Assert-eq (elt my-string 3) ?5) |
| 428 | 100 |
| 101 (fillarray my-bit-vector 0) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
102 (Assert-eq 4 (length my-bit-vector)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
103 (Assert-eq (elt my-bit-vector 2) 0) |
| 428 | 104 ) |
| 105 | |
| 106 (defun make-circular-list (length) | |
| 107 "Create evil emacs-crashing circular list of length LENGTH" | |
| 108 (let ((circular-list | |
| 109 (make-list | |
| 110 length | |
| 111 'you-are-trapped-in-a-twisty-maze-of-cons-cells-all-alike))) | |
| 112 (setcdr (last circular-list) circular-list) | |
| 113 circular-list)) | |
| 114 | |
| 115 ;;----------------------------------------------------- | |
| 116 ;; Test `nconc' | |
| 117 ;;----------------------------------------------------- | |
| 118 (defun make-list-012 () (list 0 1 2)) | |
| 119 | |
| 120 (Check-Error wrong-type-argument (nconc 'foo nil)) | |
| 121 | |
| 122 (dolist (length '(1 2 3 4 1000 2000)) | |
| 123 (Check-Error circular-list (nconc (make-circular-list length) 'foo)) | |
| 124 (Check-Error circular-list (nconc '(1 . 2) (make-circular-list length) 'foo)) | |
| 125 (Check-Error circular-list (nconc '(1 . 2) '(3 . 4) (make-circular-list length) 'foo))) | |
| 126 | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
127 (Assert-eq (nconc) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
128 (Assert-eq (nconc nil) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
129 (Assert-eq (nconc nil nil) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
130 (Assert-eq (nconc nil nil nil) nil) |
| 428 | 131 |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
132 (let ((x (make-list-012))) (Assert-eq (nconc nil x) x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
133 (let ((x (make-list-012))) (Assert-eq (nconc x nil) x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
134 (let ((x (make-list-012))) (Assert-eq (nconc nil x nil) x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
135 (let ((x (make-list-012))) (Assert-eq (nconc x) x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
136 (let ((x (make-list-012))) (Assert-eq (nconc x (make-circular-list 3)) x)) |
| 428 | 137 |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
138 (Assert-equal (nconc '(1 . 2) '(3 . 4) '(5 . 6)) '(1 3 5 . 6)) |
| 428 | 139 |
| 140 (let ((y (nconc (make-list-012) nil (list 3 4 5) nil))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
141 (Assert-eq (length y) 6) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
142 (Assert-eq (nth 3 y) 3)) |
| 428 | 143 |
| 144 ;;----------------------------------------------------- | |
| 145 ;; Test `last' | |
| 146 ;;----------------------------------------------------- | |
| 147 (Check-Error wrong-type-argument (last 'foo)) | |
| 148 (Check-Error wrong-number-of-arguments (last)) | |
| 149 (Check-Error wrong-number-of-arguments (last '(1 2) 1 1)) | |
| 150 (Check-Error circular-list (last (make-circular-list 1))) | |
| 151 (Check-Error circular-list (last (make-circular-list 2000))) | |
| 152 (let ((x (list 0 1 2 3))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
153 (Assert-eq (last nil) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
154 (Assert-eq (last x 0) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
155 (Assert-eq (last x ) (cdddr x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
156 (Assert-eq (last x 1) (cdddr x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
157 (Assert-eq (last x 2) (cddr x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
158 (Assert-eq (last x 3) (cdr x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
159 (Assert-eq (last x 4) x) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
160 (Assert-eq (last x 9) x) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
161 (Assert-eq (last '(1 . 2) 0) 2) |
| 428 | 162 ) |
| 163 | |
| 164 ;;----------------------------------------------------- | |
| 165 ;; Test `butlast' and `nbutlast' | |
| 166 ;;----------------------------------------------------- | |
| 167 (Check-Error wrong-type-argument (butlast 'foo)) | |
| 168 (Check-Error wrong-type-argument (nbutlast 'foo)) | |
| 169 (Check-Error wrong-number-of-arguments (butlast)) | |
| 170 (Check-Error wrong-number-of-arguments (nbutlast)) | |
| 171 (Check-Error wrong-number-of-arguments (butlast '(1 2) 1 1)) | |
| 172 (Check-Error wrong-number-of-arguments (nbutlast '(1 2) 1 1)) | |
| 173 (Check-Error circular-list (butlast (make-circular-list 1))) | |
| 174 (Check-Error circular-list (nbutlast (make-circular-list 1))) | |
| 175 (Check-Error circular-list (butlast (make-circular-list 2000))) | |
| 176 (Check-Error circular-list (nbutlast (make-circular-list 2000))) | |
| 177 | |
| 178 (let* ((x (list 0 1 2 3)) | |
| 179 (y (butlast x)) | |
| 180 (z (nbutlast x))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
181 (Assert-eq z x) |
| 428 | 182 (Assert (not (eq y x))) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
183 (Assert-equal y '(0 1 2)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
184 (Assert-equal z y)) |
| 428 | 185 |
| 186 (let* ((x (list 0 1 2 3 4)) | |
| 187 (y (butlast x 2)) | |
| 188 (z (nbutlast x 2))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
189 (Assert-eq z x) |
| 428 | 190 (Assert (not (eq y x))) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
191 (Assert-equal y '(0 1 2)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
192 (Assert-equal z y)) |
| 428 | 193 |
| 194 (let* ((x (list 0 1 2 3)) | |
| 195 (y (butlast x 0)) | |
| 196 (z (nbutlast x 0))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
197 (Assert-eq z x) |
| 428 | 198 (Assert (not (eq y x))) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
199 (Assert-equal y '(0 1 2 3)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
200 (Assert-equal z y)) |
| 428 | 201 |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
202 (Assert-eq (butlast '(x)) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
203 (Assert-eq (nbutlast '(x)) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
204 (Assert-eq (butlast '()) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
205 (Assert-eq (nbutlast '()) nil) |
| 428 | 206 |
| 207 ;;----------------------------------------------------- | |
| 208 ;; Test `copy-list' | |
| 209 ;;----------------------------------------------------- | |
| 210 (Check-Error wrong-type-argument (copy-list 'foo)) | |
| 211 (Check-Error wrong-number-of-arguments (copy-list)) | |
| 212 (Check-Error wrong-number-of-arguments (copy-list '(1 2) 1)) | |
| 213 (Check-Error circular-list (copy-list (make-circular-list 1))) | |
| 214 (Check-Error circular-list (copy-list (make-circular-list 2000))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
215 (Assert-eq '() (copy-list '())) |
| 428 | 216 (dolist (x '((1) (1 2) (1 2 3) (1 2 . 3))) |
| 217 (let ((y (copy-list x))) | |
| 218 (Assert (and (equal x y) (not (eq x y)))))) | |
| 219 | |
| 220 ;;----------------------------------------------------- | |
| 221 ;; Arithmetic operations | |
| 222 ;;----------------------------------------------------- | |
| 223 | |
| 224 ;; Test `+' | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
225 (Assert-eq (+ 1 1) 2) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
226 (Assert= (+ 1.0 1.0) 2.0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
227 (Assert= (+ 1.0 3.0 0.0) 4.0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
228 (Assert= (+ 1 1.0) 2.0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
229 (Assert= (+ 1.0 1) 2.0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
230 (Assert= (+ 1.0 1 1) 3.0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
231 (Assert= (+ 1 1 1.0) 3.0) |
| 1983 | 232 (if (featurep 'bignum) |
| 233 (progn | |
| 234 (Assert (bignump (1+ most-positive-fixnum))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
235 (Assert-eq most-positive-fixnum (1- (1+ most-positive-fixnum))) |
| 1983 | 236 (Assert (bignump (+ most-positive-fixnum 1))) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
237 (Assert-eq most-positive-fixnum (- (+ most-positive-fixnum 1) 1)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
238 (Assert= (1+ most-positive-fixnum) (- most-negative-fixnum)) |
| 1983 | 239 (Assert (zerop (+ (* 3 most-negative-fixnum) (* 3 most-positive-fixnum) |
| 240 3)))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
241 (Assert-eq (1+ most-positive-fixnum) most-negative-fixnum) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
242 (Assert-eq (+ most-positive-fixnum 1) most-negative-fixnum)) |
| 1983 | 243 |
| 244 (when (featurep 'ratio) | |
| 245 (let ((threefourths (read "3/4")) | |
| 246 (threehalfs (read "3/2")) | |
| 247 (bigpos (div (+ most-positive-fixnum 2) (1+ most-positive-fixnum))) | |
| 248 (bigneg (div (+ most-positive-fixnum 2) most-negative-fixnum)) | |
| 249 (negone (div (1+ most-positive-fixnum) most-negative-fixnum))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
250 (Assert= negone -1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
251 (Assert= threehalfs (+ threefourths threefourths)) |
| 1983 | 252 (Assert (zerop (+ bigpos bigneg))))) |
| 428 | 253 |
| 254 ;; Test `-' | |
| 255 (Check-Error wrong-number-of-arguments (-)) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
256 (Assert-eq (- 0) 0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
257 (Assert-eq (- 1) -1) |
| 428 | 258 (dolist (one `(1 1.0 ?\1 ,(Int-to-Marker 1))) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
259 (Assert= (+ 1 one) 2) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
260 (Assert= (+ one) 1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
261 (Assert= (+ one) one) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
262 (Assert= (- one) -1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
263 (Assert= (- one one) 0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
264 (Assert= (- one one one) -1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
265 (Assert= (- 0 one) -1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
266 (Assert= (- 0 one one) -2) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
267 (Assert= (+ one 1) 2) |
| 428 | 268 (dolist (zero '(0 0.0 ?\0)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
269 (Assert= (+ 1 zero) 1 zero) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
270 (Assert= (+ zero 1) 1 zero) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
271 (Assert= (- zero) zero zero) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
272 (Assert= (- zero) 0 zero) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
273 (Assert= (- zero zero) 0 zero) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
274 (Assert= (- zero one one) -2 zero))) |
| 428 | 275 |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
276 (Assert= (- 1.5 1) .5) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
277 (Assert= (- 1 1.5) (- .5)) |
| 428 | 278 |
| 1983 | 279 (if (featurep 'bignum) |
| 280 (progn | |
| 281 (Assert (bignump (1- most-negative-fixnum))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
282 (Assert-eq most-negative-fixnum (1+ (1- most-negative-fixnum))) |
| 1983 | 283 (Assert (bignump (- most-negative-fixnum 1))) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
284 (Assert-eq most-negative-fixnum (+ (- most-negative-fixnum 1) 1)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
285 (Assert= (1- most-negative-fixnum) (- 0 most-positive-fixnum 2)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
286 (Assert-eq (- (- most-positive-fixnum most-negative-fixnum) |
| 1983 | 287 (* 2 most-positive-fixnum)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
288 1)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
289 (Assert-eq (1- most-negative-fixnum) most-positive-fixnum) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
290 (Assert-eq (- most-negative-fixnum 1) most-positive-fixnum)) |
| 1983 | 291 |
| 292 (when (featurep 'ratio) | |
| 293 (let ((threefourths (read "3/4")) | |
| 294 (threehalfs (read "3/2")) | |
| 295 (bigpos (div (+ most-positive-fixnum 2) (1+ most-positive-fixnum))) | |
| 296 (bigneg (div most-positive-fixnum most-negative-fixnum)) | |
| 297 (negone (div (1+ most-positive-fixnum) most-negative-fixnum))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
298 (Assert= (- negone) 1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
299 (Assert= threefourths (- threehalfs threefourths)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
300 (Assert= (- bigpos bigneg) 2))) |
| 428 | 301 |
| 302 ;; Test `/' | |
| 303 | |
| 304 ;; Test division by zero errors | |
| 305 (dolist (zero '(0 0.0 ?\0)) | |
| 306 (Check-Error arith-error (/ zero)) | |
| 307 (dolist (n1 `(42 42.0 ?\042 ,(Int-to-Marker 42))) | |
| 308 (Check-Error arith-error (/ n1 zero)) | |
| 309 (dolist (n2 `(3 3.0 ?\03 ,(Int-to-Marker 3))) | |
| 310 (Check-Error arith-error (/ n1 n2 zero))))) | |
| 311 | |
| 312 ;; Other tests for `/' | |
| 313 (Check-Error wrong-number-of-arguments (/)) | |
| 314 (let (x) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
315 (Assert= (/ (setq x 2)) 0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
316 (Assert= (/ (setq x 2.0)) 0.5)) |
| 428 | 317 |
| 318 (dolist (six '(6 6.0 ?\06)) | |
| 319 (dolist (two '(2 2.0 ?\02)) | |
| 320 (dolist (three '(3 3.0 ?\03)) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
321 (Assert= (/ six two) three (list six two three))))) |
| 428 | 322 |
| 323 (dolist (three '(3 3.0 ?\03)) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
324 (Assert= (/ three 2.0) 1.5 three)) |
| 428 | 325 (dolist (two '(2 2.0 ?\02)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
326 (Assert= (/ 3.0 two) 1.5 two)) |
| 428 | 327 |
| 1983 | 328 (when (featurep 'bignum) |
| 329 (let* ((million 1000000) | |
| 330 (billion (* million 1000)) ;; American, not British, billion | |
| 331 (trillion (* billion 1000))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
332 (Assert= (/ billion 1000) (/ trillion million) million 1000000.0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
333 (Assert= (/ billion -1000) (/ trillion (- million)) (- million)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
334 (Assert= (/ trillion 1000) billion 1000000000.0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
335 (Assert= (/ trillion -1000) (- billion) -1000000000.0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
336 (Assert= (/ trillion 10) (* 100 billion) 100000000000.0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
337 (Assert= (/ (- trillion) 10) (* -100 billion) -100000000000.0))) |
| 1983 | 338 |
| 339 (when (featurep 'ratio) | |
| 340 (let ((half (div 1 2)) | |
| 341 (fivefourths (div 5 4)) | |
| 342 (fivehalfs (div 5 2))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
343 (Assert= half (read "3000000000/6000000000")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
344 (Assert= (/ fivehalfs fivefourths) 2) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
345 (Assert= (/ fivefourths fivehalfs) half) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
346 (Assert= (- half) (read "-3000000000/6000000000")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
347 (Assert= (/ fivehalfs (- fivefourths)) -2) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
348 (Assert= (/ (- fivefourths) fivehalfs) (- half)))) |
| 1983 | 349 |
| 428 | 350 ;; Test `*' |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
351 (Assert= 1 (*)) |
| 428 | 352 |
| 353 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
354 (Assert= 1 (* one) one)) |
| 428 | 355 |
| 356 (dolist (two '(2 2.0 ?\02)) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
357 (Assert= 2 (* two) two)) |
| 428 | 358 |
| 359 (dolist (six '(6 6.0 ?\06)) | |
| 360 (dolist (two '(2 2.0 ?\02)) | |
| 361 (dolist (three '(3 3.0 ?\03)) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
362 (Assert= (* three two) six (list three two six))))) |
| 428 | 363 |
| 364 (dolist (three '(3 3.0 ?\03)) | |
| 365 (dolist (two '(2 2.0 ?\02)) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
366 (Assert= (* 1.5 two) three (list two three)) |
| 428 | 367 (dolist (five '(5 5.0 ?\05)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
368 (Assert= 30 (* five two three) (list five two three))))) |
| 428 | 369 |
| 1983 | 370 (when (featurep 'bignum) |
| 371 (let ((64K 65536)) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
372 (Assert= (* 64K 64K) (read "4294967296")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
373 (Assert= (* (- 64K) 64K) (read "-4294967296")) |
| 1983 | 374 (Assert (/= (* -1 most-negative-fixnum) most-negative-fixnum)))) |
| 375 | |
| 376 (when (featurep 'ratio) | |
| 377 (let ((half (div 1 2)) | |
| 378 (fivefourths (div 5 4)) | |
| 379 (twofifths (div 2 5))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
380 (Assert= (* fivefourths twofifths) half) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
381 (Assert= (* half twofifths) (read "3/15")))) |
| 1983 | 382 |
| 428 | 383 ;; Test `+' |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
384 (Assert= 0 (+)) |
| 428 | 385 |
| 386 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
387 (Assert= 1 (+ one) one)) |
| 428 | 388 |
| 389 (dolist (two '(2 2.0 ?\02)) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
390 (Assert= 2 (+ two) two)) |
| 428 | 391 |
| 392 (dolist (five '(5 5.0 ?\05)) | |
| 393 (dolist (two '(2 2.0 ?\02)) | |
| 394 (dolist (three '(3 3.0 ?\03)) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
395 (Assert= (+ three two) five (list three two five)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
396 (Assert= 10 (+ five two three) (list five two three))))) |
| 428 | 397 |
| 398 ;; Test `max', `min' | |
| 399 (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
400 (Assert= one (max one) one) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
401 (Assert= one (max one one) one) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
402 (Assert= one (max one one one) one) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
403 (Assert= one (min one) one) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
404 (Assert= one (min one one) one) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
405 (Assert= one (min one one one) one) |
| 428 | 406 (dolist (two `(2 2.0 ?\02 ,(Int-to-Marker 2))) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
407 (Assert= one (min one two) (list one two)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
408 (Assert= one (min one two two) (list one two)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
409 (Assert= one (min two two one) (list one two)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
410 (Assert= two (max one two) (list one two)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
411 (Assert= two (max one two two) (list one two)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
412 (Assert= two (max two two one) (list one two)))) |
| 428 | 413 |
| 1983 | 414 (when (featurep 'bignum) |
| 415 (let ((big (1+ most-positive-fixnum)) | |
| 416 (small (1- most-negative-fixnum))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
417 (Assert= big (max 1 1000000.0 most-positive-fixnum big)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
418 (Assert= small (min -1 -1000000.0 most-negative-fixnum small)))) |
| 1983 | 419 |
| 420 (when (featurep 'ratio) | |
| 421 (let* ((big (1+ most-positive-fixnum)) | |
| 422 (small (1- most-negative-fixnum)) | |
| 423 (bigr (div (* 5 (1+ most-positive-fixnum)) 4)) | |
| 424 (smallr (- bigr))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
425 (Assert= bigr (max 1 1000000.0 most-positive-fixnum big bigr)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
426 (Assert= smallr (min -1 -1000000.0 most-negative-fixnum small smallr)))) |
| 1983 | 427 |
| 446 | 428 ;; The byte compiler has special handling for these constructs: |
| 429 (let ((three 3) (five 5)) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
430 (Assert= (+ three five 1) 9) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
431 (Assert= (+ 1 three five) 9) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
432 (Assert= (+ three five -1) 7) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
433 (Assert= (+ -1 three five) 7) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
434 (Assert= (+ three 1) 4) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
435 (Assert= (+ three -1) 2) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
436 (Assert= (+ -1 three) 2) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
437 (Assert= (+ -1 three) 2) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
438 (Assert= (- three five 1) -3) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
439 (Assert= (- 1 three five) -7) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
440 (Assert= (- three five -1) -1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
441 (Assert= (- -1 three five) -9) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
442 (Assert= (- three 1) 2) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
443 (Assert= (- three 2 1) 0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
444 (Assert= (- 2 three 1) -2) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
445 (Assert= (- three -1) 4) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
446 (Assert= (- three 0) 3) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
447 (Assert= (- three 0 five) -2) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
448 (Assert= (- 0 three 0 five) -8) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
449 (Assert= (- 0 three five) -8) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
450 (Assert= (* three 2) 6) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
451 (Assert= (* three -1 five) -15) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
452 (Assert= (* three 1 five) 15) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
453 (Assert= (* three 0 five) 0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
454 (Assert= (* three 2 five) 30) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
455 (Assert= (/ three 1) 3) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
456 (Assert= (/ three -1) -3) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
457 (Assert= (/ (* five five) 2 2) 6) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
458 (Assert= (/ 64 five 2) 6)) |
| 446 | 459 |
| 460 | |
| 428 | 461 ;;----------------------------------------------------- |
| 462 ;; Logical bit-twiddling operations | |
| 463 ;;----------------------------------------------------- | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
464 (Assert= (logxor) 0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
465 (Assert= (logior) 0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
466 (Assert= (logand) -1) |
| 428 | 467 |
| 468 (Check-Error wrong-type-argument (logxor 3.0)) | |
| 469 (Check-Error wrong-type-argument (logior 3.0)) | |
| 470 (Check-Error wrong-type-argument (logand 3.0)) | |
| 471 | |
| 472 (dolist (three '(3 ?\03)) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
473 (Assert-eq 3 (logand three) three) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
474 (Assert-eq 3 (logxor three) three) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
475 (Assert-eq 3 (logior three) three) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
476 (Assert-eq 3 (logand three three) three) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
477 (Assert-eq 0 (logxor three three) three) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
478 (Assert-eq 3 (logior three three)) three) |
| 428 | 479 |
| 480 (dolist (one `(1 ?\01 ,(Int-to-Marker 1))) | |
| 481 (dolist (two '(2 ?\02)) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
482 (Assert-eq 0 (logand one two) (list one two)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
483 (Assert-eq 3 (logior one two) (list one two)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
484 (Assert-eq 3 (logxor one two) (list one two))) |
| 428 | 485 (dolist (three '(3 ?\03)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
486 (Assert-eq 1 (logand one three) (list one three)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
487 (Assert-eq 3 (logior one three) (list one three)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
488 (Assert-eq 2 (logxor one three) (list one three)))) |
| 428 | 489 |
| 490 ;;----------------------------------------------------- | |
| 491 ;; Test `%', mod | |
| 492 ;;----------------------------------------------------- | |
| 493 (Check-Error wrong-number-of-arguments (%)) | |
| 494 (Check-Error wrong-number-of-arguments (% 1)) | |
| 495 (Check-Error wrong-number-of-arguments (% 1 2 3)) | |
| 496 | |
| 497 (Check-Error wrong-number-of-arguments (mod)) | |
| 498 (Check-Error wrong-number-of-arguments (mod 1)) | |
| 499 (Check-Error wrong-number-of-arguments (mod 1 2 3)) | |
| 500 | |
| 501 (Check-Error wrong-type-argument (% 10.0 2)) | |
| 502 (Check-Error wrong-type-argument (% 10 2.0)) | |
| 503 | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
504 (flet ((test1 (x) (Assert-eql x (+ (% x 17) (* (/ x 17) 17)) x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
505 (test2 (x) (Assert-eql (- x) (+ (% (- x) 17) (* (/ (- x) 17) 17)) x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
506 (test3 (x) (Assert-eql x (+ (% (- x) 17) (* (/ (- x) 17) 17)) x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
507 (test4 (x) (Assert-eql (% x -17) (- (% (- x) 17)) x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
508 (test5 (x) (Assert-eql (% x -17) (% (- x) 17)) x)) |
| 2056 | 509 (test1 most-negative-fixnum) |
| 510 (if (featurep 'bignum) | |
| 2075 | 511 (progn |
| 512 (test2 most-negative-fixnum) | |
| 513 (test4 most-negative-fixnum)) | |
| 514 (test3 most-negative-fixnum) | |
| 515 (test5 most-negative-fixnum)) | |
| 2056 | 516 (test1 most-positive-fixnum) |
| 517 (test2 most-positive-fixnum) | |
| 518 (test4 most-positive-fixnum) | |
| 519 (dotimes (j 30) | |
| 520 (let ((x (random))) | |
| 521 (if (eq x most-negative-fixnum) (setq x (1+ x))) | |
| 522 (if (eq x most-positive-fixnum) (setq x (1- x))) | |
| 523 (test1 x) | |
| 524 (test2 x) | |
| 525 (test4 x)))) | |
| 428 | 526 |
| 527 (macrolet | |
| 528 ((division-test (seven) | |
| 529 `(progn | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
530 (Assert-eq (% ,seven 2) 1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
531 (Assert-eq (% ,seven -2) 1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
532 (Assert-eq (% (- ,seven) 2) -1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
533 (Assert-eq (% (- ,seven) -2) -1) |
| 428 | 534 |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
535 (Assert-eq (% ,seven 4) 3) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
536 (Assert-eq (% ,seven -4) 3) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
537 (Assert-eq (% (- ,seven) 4) -3) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
538 (Assert-eq (% (- ,seven) -4) -3) |
| 428 | 539 |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
540 (Assert-eq (% 35 ,seven) 0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
541 (Assert-eq (% -35 ,seven) 0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
542 (Assert-eq (% 35 (- ,seven)) 0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
543 (Assert-eq (% -35 (- ,seven)) 0) |
| 428 | 544 |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
545 (Assert-eq (mod ,seven 2) 1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
546 (Assert-eq (mod ,seven -2) -1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
547 (Assert-eq (mod (- ,seven) 2) 1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
548 (Assert-eq (mod (- ,seven) -2) -1) |
| 428 | 549 |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
550 (Assert-eq (mod ,seven 4) 3) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
551 (Assert-eq (mod ,seven -4) -1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
552 (Assert-eq (mod (- ,seven) 4) 1) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
553 (Assert-eq (mod (- ,seven) -4) -3) |
| 428 | 554 |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
555 (Assert-eq (mod 35 ,seven) 0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
556 (Assert-eq (mod -35 ,seven) 0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
557 (Assert-eq (mod 35 (- ,seven)) 0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
558 (Assert-eq (mod -35 (- ,seven)) 0) |
| 428 | 559 |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
560 (Assert= (mod ,seven 2.0) 1.0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
561 (Assert= (mod ,seven -2.0) -1.0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
562 (Assert= (mod (- ,seven) 2.0) 1.0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
563 (Assert= (mod (- ,seven) -2.0) -1.0) |
| 428 | 564 |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
565 (Assert= (mod ,seven 4.0) 3.0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
566 (Assert= (mod ,seven -4.0) -1.0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
567 (Assert= (mod (- ,seven) 4.0) 1.0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
568 (Assert= (mod (- ,seven) -4.0) -3.0) |
| 428 | 569 |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
570 (Assert-eq (% 0 ,seven) 0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
571 (Assert-eq (% 0 (- ,seven)) 0) |
| 428 | 572 |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
573 (Assert-eq (mod 0 ,seven) 0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
574 (Assert-eq (mod 0 (- ,seven)) 0) |
| 428 | 575 |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
576 (Assert= (mod 0.0 ,seven) 0.0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
577 (Assert= (mod 0.0 (- ,seven)) 0.0)))) |
| 428 | 578 |
| 579 (division-test 7) | |
| 580 (division-test ?\07) | |
| 581 (division-test (Int-to-Marker 7))) | |
| 582 | |
| 1983 | 583 (when (featurep 'bignum) |
| 584 (let ((big (+ (* 7 most-positive-fixnum 6))) | |
| 585 (negbig (- (* 7 most-negative-fixnum 6)))) | |
| 586 (= (% big (1+ most-positive-fixnum)) most-positive-fixnum) | |
| 587 (= (% negbig (1- most-negative-fixnum)) most-negative-fixnum) | |
| 588 (= (mod big (1+ most-positive-fixnum)) most-positive-fixnum) | |
| 589 (= (mod negbig (1- most-negative-fixnum)) most-negative-fixnum))) | |
| 428 | 590 |
| 591 ;;----------------------------------------------------- | |
| 592 ;; Arithmetic comparison operations | |
| 593 ;;----------------------------------------------------- | |
| 594 (Check-Error wrong-number-of-arguments (=)) | |
| 595 (Check-Error wrong-number-of-arguments (<)) | |
| 596 (Check-Error wrong-number-of-arguments (>)) | |
| 597 (Check-Error wrong-number-of-arguments (<=)) | |
| 598 (Check-Error wrong-number-of-arguments (>=)) | |
| 599 (Check-Error wrong-number-of-arguments (/=)) | |
| 600 | |
| 601 ;; One argument always yields t | |
| 602 (loop for x in `(1 1.0 ,(Int-to-Marker 1) ?z) do | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
603 (Assert-eq t (= x) x) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
604 (Assert-eq t (< x) x) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
605 (Assert-eq t (> x) x) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
606 (Assert-eq t (>= x) x) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
607 (Assert-eq t (<= x) x) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
608 (Assert-eq t (/= x) x) |
| 428 | 609 ) |
| 610 | |
| 611 ;; Type checking | |
| 612 (Check-Error wrong-type-argument (= 'foo 1)) | |
| 613 (Check-Error wrong-type-argument (<= 'foo 1)) | |
| 614 (Check-Error wrong-type-argument (>= 'foo 1)) | |
| 615 (Check-Error wrong-type-argument (< 'foo 1)) | |
| 616 (Check-Error wrong-type-argument (> 'foo 1)) | |
| 617 (Check-Error wrong-type-argument (/= 'foo 1)) | |
| 618 | |
| 619 ;; Meat | |
| 620 (dolist (one `(1 1.0 ,(Int-to-Marker 1) ?\01)) | |
| 621 (dolist (two '(2 2.0 ?\02)) | |
| 2056 | 622 (Assert (< one two) (list one two)) |
| 623 (Assert (<= one two) (list one two)) | |
| 624 (Assert (<= two two) two) | |
| 625 (Assert (> two one) (list one two)) | |
| 626 (Assert (>= two one) (list one two)) | |
| 627 (Assert (>= two two) two) | |
| 628 (Assert (/= one two) (list one two)) | |
| 629 (Assert (not (/= two two)) two) | |
| 630 (Assert (not (< one one)) one) | |
| 631 (Assert (not (> one one)) one) | |
| 632 (Assert (<= one one two two) (list one two)) | |
| 633 (Assert (not (< one one two two)) (list one two)) | |
| 634 (Assert (>= two two one one) (list one two)) | |
| 635 (Assert (not (> two two one one)) (list one two)) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
636 (Assert= one one one one) |
| 2056 | 637 (Assert (not (= one one one two)) (list one two)) |
| 638 (Assert (not (/= one two one)) (list one two)) | |
| 428 | 639 )) |
| 640 | |
| 641 (dolist (one `(1 1.0 ,(Int-to-Marker 1) ?\01)) | |
| 642 (dolist (two '(2 2.0 ?\02)) | |
| 2056 | 643 (Assert (< one two) (list one two)) |
| 644 (Assert (<= one two) (list one two)) | |
| 645 (Assert (<= two two) two) | |
| 646 (Assert (> two one) (list one two)) | |
| 647 (Assert (>= two one) (list one two)) | |
| 648 (Assert (>= two two) two) | |
| 649 (Assert (/= one two) (list one two)) | |
| 650 (Assert (not (/= two two)) two) | |
| 651 (Assert (not (< one one)) one) | |
| 652 (Assert (not (> one one)) one) | |
| 653 (Assert (<= one one two two) (list one two)) | |
| 654 (Assert (not (< one one two two)) (list one two)) | |
| 655 (Assert (>= two two one one) (list one two)) | |
| 656 (Assert (not (> two two one one)) (list one two)) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
657 (Assert= one one one one) |
| 2056 | 658 (Assert (not (= one one one two)) (list one two)) |
| 659 (Assert (not (/= one two one)) (list one two)) | |
| 428 | 660 )) |
| 661 | |
| 662 ;; ad-hoc | |
| 663 (Assert (< 1 2)) | |
| 664 (Assert (< 1 2 3 4 5 6)) | |
| 665 (Assert (not (< 1 1))) | |
| 666 (Assert (not (< 2 1))) | |
| 667 | |
| 668 | |
| 669 (Assert (not (< 1 1))) | |
| 670 (Assert (< 1 2 3 4 5 6)) | |
| 671 (Assert (<= 1 2 3 4 5 6)) | |
| 672 (Assert (<= 1 2 3 4 5 6 6)) | |
| 673 (Assert (not (< 1 2 3 4 5 6 6))) | |
| 674 (Assert (<= 1 1)) | |
| 675 | |
| 676 (Assert (not (eq (point) (point-marker)))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
677 (Assert= 1 (Int-to-Marker 1)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
678 (Assert= (point) (point-marker)) |
| 428 | 679 |
| 1983 | 680 (when (featurep 'bignum) |
| 681 (let ((big1 (1+ most-positive-fixnum)) | |
| 682 (big2 (* 10 most-positive-fixnum)) | |
| 683 (small1 (1- most-negative-fixnum)) | |
| 684 (small2 (* 10 most-negative-fixnum))) | |
| 685 (Assert (< small2 small1 most-negative-fixnum most-positive-fixnum big1 | |
| 686 big2)) | |
| 687 (Assert (<= small2 small1 most-negative-fixnum most-positive-fixnum big1 | |
| 688 big2)) | |
| 689 (Assert (> big2 big1 most-positive-fixnum most-negative-fixnum small1 | |
| 690 small2)) | |
| 691 (Assert (>= big2 big1 most-positive-fixnum most-negative-fixnum small1 | |
| 692 small2)) | |
| 693 (Assert (/= small2 small1 most-negative-fixnum most-positive-fixnum big1 | |
| 694 big2)))) | |
| 695 | |
| 696 (when (featurep 'ratio) | |
| 697 (let ((big1 (div (* 10 most-positive-fixnum) 4)) | |
| 698 (big2 (div (* 5 most-positive-fixnum) 2)) | |
| 699 (big3 (div (* 7 most-positive-fixnum) 2)) | |
| 700 (small1 (div (* 10 most-negative-fixnum) 4)) | |
| 701 (small2 (div (* 5 most-negative-fixnum) 2)) | |
| 702 (small3 (div (* 7 most-negative-fixnum) 2))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
703 (Assert= big1 big2) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
704 (Assert= small1 small2) |
| 1983 | 705 (Assert (< small3 small1 most-negative-fixnum most-positive-fixnum big1 |
| 706 big3)) | |
| 707 (Assert (<= small3 small2 small1 most-negative-fixnum most-positive-fixnum | |
| 708 big1 big2 big3)) | |
| 709 (Assert (> big3 big1 most-positive-fixnum most-negative-fixnum small1 | |
| 710 small3)) | |
| 711 (Assert (>= big3 big2 big1 most-positive-fixnum most-negative-fixnum | |
| 712 small1 small2 small3)) | |
| 713 (Assert (/= big3 big1 most-positive-fixnum most-negative-fixnum small1 | |
| 714 small3)))) | |
| 715 | |
| 428 | 716 ;;----------------------------------------------------- |
| 717 ;; testing list-walker functions | |
| 718 ;;----------------------------------------------------- | |
| 719 (macrolet | |
| 720 ((test-fun | |
| 721 (fun) | |
| 722 `(progn | |
| 723 (Check-Error wrong-number-of-arguments (,fun)) | |
| 724 (Check-Error wrong-number-of-arguments (,fun nil)) | |
| 725 (Check-Error malformed-list (,fun nil 1)) | |
| 726 ,@(loop for n in '(1 2 2000) | |
| 727 collect `(Check-Error circular-list (,fun 1 (make-circular-list ,n)))))) | |
| 728 (test-funs (&rest funs) `(progn ,@(loop for fun in funs collect `(test-fun ,fun))))) | |
| 729 | |
| 730 (test-funs member old-member | |
| 731 memq old-memq | |
| 732 assoc old-assoc | |
| 733 rassoc old-rassoc | |
| 734 rassq old-rassq | |
| 735 delete old-delete | |
| 736 delq old-delq | |
| 737 remassoc remassq remrassoc remrassq)) | |
| 738 | |
| 739 (let ((x '((1 . 2) 3 (4 . 5)))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
740 (Assert-eq (assoc 1 x) (car x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
741 (Assert-eq (assq 1 x) (car x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
742 (Assert-eq (rassoc 1 x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
743 (Assert-eq (rassq 1 x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
744 (Assert-eq (assoc 2 x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
745 (Assert-eq (assq 2 x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
746 (Assert-eq (rassoc 2 x) (car x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
747 (Assert-eq (rassq 2 x) (car x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
748 (Assert-eq (assoc 3 x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
749 (Assert-eq (assq 3 x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
750 (Assert-eq (rassoc 3 x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
751 (Assert-eq (rassq 3 x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
752 (Assert-eq (assoc 4 x) (caddr x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
753 (Assert-eq (assq 4 x) (caddr x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
754 (Assert-eq (rassoc 4 x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
755 (Assert-eq (rassq 4 x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
756 (Assert-eq (assoc 5 x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
757 (Assert-eq (assq 5 x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
758 (Assert-eq (rassoc 5 x) (caddr x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
759 (Assert-eq (rassq 5 x) (caddr x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
760 (Assert-eq (assoc 6 x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
761 (Assert-eq (assq 6 x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
762 (Assert-eq (rassoc 6 x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
763 (Assert-eq (rassq 6 x) nil)) |
| 428 | 764 |
| 765 (let ((x '(("1" . "2") "3" ("4" . "5")))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
766 (Assert-eq (assoc "1" x) (car x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
767 (Assert-eq (assq "1" x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
768 (Assert-eq (rassoc "1" x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
769 (Assert-eq (rassq "1" x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
770 (Assert-eq (assoc "2" x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
771 (Assert-eq (assq "2" x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
772 (Assert-eq (rassoc "2" x) (car x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
773 (Assert-eq (rassq "2" x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
774 (Assert-eq (assoc "3" x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
775 (Assert-eq (assq "3" x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
776 (Assert-eq (rassoc "3" x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
777 (Assert-eq (rassq "3" x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
778 (Assert-eq (assoc "4" x) (caddr x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
779 (Assert-eq (assq "4" x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
780 (Assert-eq (rassoc "4" x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
781 (Assert-eq (rassq "4" x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
782 (Assert-eq (assoc "5" x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
783 (Assert-eq (assq "5" x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
784 (Assert-eq (rassoc "5" x) (caddr x)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
785 (Assert-eq (rassq "5" x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
786 (Assert-eq (assoc "6" x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
787 (Assert-eq (assq "6" x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
788 (Assert-eq (rassoc "6" x) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
789 (Assert-eq (rassq "6" x) nil)) |
| 428 | 790 |
| 791 (flet ((a () (list '(1 . 2) 3 '(4 . 5)))) | |
| 792 (Assert (let* ((x (a)) (y (remassoc 1 x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) | |
| 793 (Assert (let* ((x (a)) (y (remassq 1 x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) | |
| 794 (Assert (let* ((x (a)) (y (remrassoc 1 x))) (and (eq x y) (equal y (a))))) | |
| 795 (Assert (let* ((x (a)) (y (remrassq 1 x))) (and (eq x y) (equal y (a))))) | |
| 796 | |
| 797 (Assert (let* ((x (a)) (y (remassoc 2 x))) (and (eq x y) (equal y (a))))) | |
| 798 (Assert (let* ((x (a)) (y (remassq 2 x))) (and (eq x y) (equal y (a))))) | |
| 799 (Assert (let* ((x (a)) (y (remrassoc 2 x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) | |
| 800 (Assert (let* ((x (a)) (y (remrassq 2 x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) | |
| 801 | |
| 802 (Assert (let* ((x (a)) (y (remassoc 3 x))) (and (eq x y) (equal y (a))))) | |
| 803 (Assert (let* ((x (a)) (y (remassq 3 x))) (and (eq x y) (equal y (a))))) | |
| 804 (Assert (let* ((x (a)) (y (remrassoc 3 x))) (and (eq x y) (equal y (a))))) | |
| 805 (Assert (let* ((x (a)) (y (remrassq 3 x))) (and (eq x y) (equal y (a))))) | |
| 806 | |
| 807 (Assert (let* ((x (a)) (y (remassoc 4 x))) (and (eq x y) (equal y '((1 . 2) 3))))) | |
| 808 (Assert (let* ((x (a)) (y (remassq 4 x))) (and (eq x y) (equal y '((1 . 2) 3))))) | |
| 809 (Assert (let* ((x (a)) (y (remrassoc 4 x))) (and (eq x y) (equal y (a))))) | |
| 810 (Assert (let* ((x (a)) (y (remrassq 4 x))) (and (eq x y) (equal y (a))))) | |
| 811 | |
| 812 (Assert (let* ((x (a)) (y (remassoc 5 x))) (and (eq x y) (equal y (a))))) | |
| 813 (Assert (let* ((x (a)) (y (remassq 5 x))) (and (eq x y) (equal y (a))))) | |
| 814 (Assert (let* ((x (a)) (y (remrassoc 5 x))) (and (eq x y) (equal y '((1 . 2) 3))))) | |
| 815 (Assert (let* ((x (a)) (y (remrassq 5 x))) (and (eq x y) (equal y '((1 . 2) 3))))) | |
| 816 | |
| 817 (Assert (let* ((x (a)) (y (remassoc 6 x))) (and (eq x y) (equal y (a))))) | |
| 818 (Assert (let* ((x (a)) (y (remassq 6 x))) (and (eq x y) (equal y (a))))) | |
| 819 (Assert (let* ((x (a)) (y (remrassoc 6 x))) (and (eq x y) (equal y (a))))) | |
| 820 (Assert (let* ((x (a)) (y (remrassq 6 x))) (and (eq x y) (equal y (a))))) | |
| 821 | |
| 822 (Assert (let* ((x (a)) (y (delete 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5)))))) | |
| 823 (Assert (let* ((x (a)) (y (delq 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5)))))) | |
| 824 (Assert (let* ((x (a)) (y (old-delete 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5)))))) | |
| 825 (Assert (let* ((x (a)) (y (old-delq 3 x))) (and (eq x y) (equal y '((1 . 2) (4 . 5)))))) | |
| 826 | |
| 827 (Assert (let* ((x (a)) (y (delete '(1 . 2) x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) | |
| 828 (Assert (let* ((x (a)) (y (delq '(1 . 2) x))) (and (eq x y) (equal y (a))))) | |
| 829 (Assert (let* ((x (a)) (y (old-delete '(1 . 2) x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) | |
| 830 (Assert (let* ((x (a)) (y (old-delq '(1 . 2) x))) (and (eq x y) (equal y (a))))) | |
| 831 ) | |
| 832 | |
| 833 | |
| 834 | |
| 835 (flet ((a () (list '("1" . "2") "3" '("4" . "5")))) | |
| 836 (Assert (let* ((x (a)) (y (remassoc "1" x))) (and (not (eq x y)) (equal y '("3" ("4" . "5")))))) | |
| 837 (Assert (let* ((x (a)) (y (remassq "1" x))) (and (eq x y) (equal y (a))))) | |
| 838 (Assert (let* ((x (a)) (y (remrassoc "1" x))) (and (eq x y) (equal y (a))))) | |
| 839 (Assert (let* ((x (a)) (y (remrassq "1" x))) (and (eq x y) (equal y (a))))) | |
| 840 | |
| 841 (Assert (let* ((x (a)) (y (remassoc "2" x))) (and (eq x y) (equal y (a))))) | |
| 842 (Assert (let* ((x (a)) (y (remassq "2" x))) (and (eq x y) (equal y (a))))) | |
| 843 (Assert (let* ((x (a)) (y (remrassoc "2" x))) (and (not (eq x y)) (equal y '("3" ("4" . "5")))))) | |
| 844 (Assert (let* ((x (a)) (y (remrassq "2" x))) (and (eq x y) (equal y (a))))) | |
| 845 | |
| 846 (Assert (let* ((x (a)) (y (remassoc "3" x))) (and (eq x y) (equal y (a))))) | |
| 847 (Assert (let* ((x (a)) (y (remassq "3" x))) (and (eq x y) (equal y (a))))) | |
| 848 (Assert (let* ((x (a)) (y (remrassoc "3" x))) (and (eq x y) (equal y (a))))) | |
| 849 (Assert (let* ((x (a)) (y (remrassq "3" x))) (and (eq x y) (equal y (a))))) | |
| 850 | |
| 851 (Assert (let* ((x (a)) (y (remassoc "4" x))) (and (eq x y) (equal y '(("1" . "2") "3"))))) | |
| 852 (Assert (let* ((x (a)) (y (remassq "4" x))) (and (eq x y) (equal y (a))))) | |
| 853 (Assert (let* ((x (a)) (y (remrassoc "4" x))) (and (eq x y) (equal y (a))))) | |
| 854 (Assert (let* ((x (a)) (y (remrassq "4" x))) (and (eq x y) (equal y (a))))) | |
| 855 | |
| 856 (Assert (let* ((x (a)) (y (remassoc "5" x))) (and (eq x y) (equal y (a))))) | |
| 857 (Assert (let* ((x (a)) (y (remassq "5" x))) (and (eq x y) (equal y (a))))) | |
| 858 (Assert (let* ((x (a)) (y (remrassoc "5" x))) (and (eq x y) (equal y '(("1" . "2") "3"))))) | |
| 859 (Assert (let* ((x (a)) (y (remrassq "5" x))) (and (eq x y) (equal y (a))))) | |
| 860 | |
| 861 (Assert (let* ((x (a)) (y (remassoc "6" x))) (and (eq x y) (equal y (a))))) | |
| 862 (Assert (let* ((x (a)) (y (remassq "6" x))) (and (eq x y) (equal y (a))))) | |
| 863 (Assert (let* ((x (a)) (y (remrassoc "6" x))) (and (eq x y) (equal y (a))))) | |
| 864 (Assert (let* ((x (a)) (y (remrassq "6" x))) (and (eq x y) (equal y (a)))))) | |
| 865 | |
| 866 ;;----------------------------------------------------- | |
| 867 ;; function-max-args, function-min-args | |
| 868 ;;----------------------------------------------------- | |
| 869 (defmacro check-function-argcounts (fun min max) | |
| 870 `(progn | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
871 (Assert-eq (function-min-args ,fun) ,min) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
872 (Assert-eq (function-max-args ,fun) ,max))) |
| 428 | 873 |
| 874 (check-function-argcounts 'prog1 1 nil) ; special form | |
| 875 (check-function-argcounts 'command-execute 1 3) ; normal subr | |
| 876 (check-function-argcounts 'funcall 1 nil) ; `MANY' subr | |
| 877 (check-function-argcounts 'garbage-collect 0 0) ; no args subr | |
| 878 | |
| 879 ;; Test interpreted and compiled functions | |
| 880 (loop for (arglist min max) in | |
| 881 '(((arg1 arg2 &rest args) 2 nil) | |
| 882 ((arg1 arg2 &optional arg3 arg4) 2 4) | |
| 883 ((arg1 arg2 &optional arg3 arg4 &rest args) 2 nil) | |
| 884 (() 0 0)) | |
| 885 do | |
| 886 (eval | |
| 887 `(progn | |
| 888 (defun test-fun ,arglist nil) | |
| 889 (check-function-argcounts '(lambda ,arglist nil) ,min ,max) | |
| 890 (check-function-argcounts (byte-compile '(lambda ,arglist nil)) ,min ,max)))) | |
| 891 | |
|
4575
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
892 ;; Test subr-arity. |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
893 (loop for (function-name arity) in |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
894 '((let (1 . unevalled)) |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
895 (prog1 (1 . unevalled)) |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
896 (list (0 . many)) |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
897 (type-of (1 . 1)) |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
898 (garbage-collect (0 . 0))) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
899 do (Assert-equal (subr-arity (symbol-function function-name)) arity)) |
|
4575
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
900 |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
901 (Check-Error wrong-type-argument (subr-arity |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
902 (lambda () (message "Hi there!")))) |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
903 |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
904 (Check-Error wrong-type-argument (subr-arity nil)) |
|
eecd28508f4a
Add #'subr-arity, API taken from GNU, implementation our own.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4396
diff
changeset
|
905 |
| 428 | 906 ;;----------------------------------------------------- |
| 907 ;; Detection of cyclic variable indirection loops | |
| 908 ;;----------------------------------------------------- | |
| 909 (fset 'test-sym1 'test-sym1) | |
| 910 (Check-Error cyclic-function-indirection (test-sym1)) | |
| 911 | |
| 912 (fset 'test-sym1 'test-sym2) | |
| 913 (fset 'test-sym2 'test-sym1) | |
| 914 (Check-Error cyclic-function-indirection (test-sym1)) | |
| 915 (fmakunbound 'test-sym1) ; else macroexpand-internal infloops! | |
| 916 (fmakunbound 'test-sym2) | |
| 917 | |
| 918 ;;----------------------------------------------------- | |
| 919 ;; Test `type-of' | |
| 920 ;;----------------------------------------------------- | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
921 (Assert-eq (type-of load-path) 'cons) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
922 (Assert-eq (type-of obarray) 'vector) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
923 (Assert-eq (type-of 42) 'integer) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
924 (Assert-eq (type-of ?z) 'character) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
925 (Assert-eq (type-of "42") 'string) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
926 (Assert-eq (type-of 'foo) 'symbol) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
927 (Assert-eq (type-of (selected-device)) 'device) |
| 428 | 928 |
| 929 ;;----------------------------------------------------- | |
| 930 ;; Test mapping functions | |
| 931 ;;----------------------------------------------------- | |
| 932 (Check-Error wrong-type-argument (mapcar #'identity (current-buffer))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
933 (Assert-equal (mapcar #'identity load-path) load-path) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
934 (Assert-equal (mapcar #'identity '(1 2 3)) '(1 2 3)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
935 (Assert-equal (mapcar #'identity "123") '(?1 ?2 ?3)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
936 (Assert-equal (mapcar #'identity [1 2 3]) '(1 2 3)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
937 (Assert-equal (mapcar #'identity #*010) '(0 1 0)) |
| 428 | 938 |
| 939 (let ((z 0) (list (make-list 1000 1))) | |
| 940 (mapc (lambda (x) (incf z x)) list) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
941 (Assert-eq 1000 z)) |
| 428 | 942 |
| 943 (Check-Error wrong-type-argument (mapvector #'identity (current-buffer))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
944 (Assert-equal (mapvector #'identity '(1 2 3)) [1 2 3]) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
945 (Assert-equal (mapvector #'identity "123") [?1 ?2 ?3]) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
946 (Assert-equal (mapvector #'identity [1 2 3]) [1 2 3]) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
947 (Assert-equal (mapvector #'identity #*010) [0 1 0]) |
| 428 | 948 |
| 949 (Check-Error wrong-type-argument (mapconcat #'identity (current-buffer) "foo")) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
950 (Assert-equal (mapconcat #'identity '("1" "2" "3") "|") "1|2|3") |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
951 (Assert-equal (mapconcat #'identity ["1" "2" "3"] "|") "1|2|3") |
| 428 | 952 |
| 434 | 953 ;; The following 2 functions used to crash XEmacs via mapcar1(). |
| 954 ;; We don't test the actual values of the mapcar, since they're undefined. | |
| 446 | 955 (Assert |
| 434 | 956 (let ((x (list (cons 1 1) (cons 2 2) (cons 3 3)))) |
| 957 (mapcar | |
| 958 (lambda (y) | |
| 959 "Devious evil mapping function" | |
| 960 (when (eq (car y) 2) ; go out onto a limb | |
| 961 (setcdr x nil) ; cut it off behind us | |
| 962 (garbage-collect)) ; are we riding a magic broomstick? | |
| 963 (car y)) ; sorry, hard landing | |
| 964 x))) | |
| 965 | |
| 446 | 966 (Assert |
| 434 | 967 (let ((x (list (cons 1 1) (cons 2 2) (cons 3 3)))) |
| 968 (mapcar | |
| 969 (lambda (y) | |
| 970 "Devious evil mapping function" | |
| 971 (when (eq (car y) 1) | |
| 972 (setcdr (cdr x) 42)) ; drop a brick wall onto the freeway | |
| 973 (car y)) | |
| 974 x))) | |
| 975 | |
| 428 | 976 ;;----------------------------------------------------- |
| 977 ;; Test vector functions | |
| 978 ;;----------------------------------------------------- | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
979 (Assert-equal [1 2 3] [1 2 3]) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
980 (Assert-equal [] []) |
| 428 | 981 (Assert (not (equal [1 2 3] []))) |
| 982 (Assert (not (equal [1 2 3] [1 2 4]))) | |
| 983 (Assert (not (equal [0 2 3] [1 2 3]))) | |
| 984 (Assert (not (equal [1 2 3] [1 2 3 4]))) | |
| 985 (Assert (not (equal [1 2 3 4] [1 2 3]))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
986 (Assert-equal (vector 1 2 3) [1 2 3]) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
987 (Assert-equal (make-vector 3 1) [1 1 1]) |
| 428 | 988 |
| 989 ;;----------------------------------------------------- | |
| 990 ;; Test bit-vector functions | |
| 991 ;;----------------------------------------------------- | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
992 (Assert-equal #*010 #*010) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
993 (Assert-equal #* #*) |
| 428 | 994 (Assert (not (equal #*010 #*011))) |
| 995 (Assert (not (equal #*010 #*))) | |
| 996 (Assert (not (equal #*110 #*010))) | |
| 997 (Assert (not (equal #*010 #*0100))) | |
| 998 (Assert (not (equal #*0101 #*010))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
999 (Assert-equal (bit-vector 0 1 0) #*010) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1000 (Assert-equal (make-bit-vector 3 1) #*111) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1001 (Assert-equal (make-bit-vector 3 0) #*000) |
| 428 | 1002 |
| 1003 ;;----------------------------------------------------- | |
| 1004 ;; Test buffer-local variables used as (ugh!) function parameters | |
| 1005 ;;----------------------------------------------------- | |
| 1006 (make-local-variable 'test-emacs-buffer-local-variable) | |
| 1007 (byte-compile | |
| 1008 (defun test-emacs-buffer-local-parameter (test-emacs-buffer-local-variable) | |
| 1009 (setq test-emacs-buffer-local-variable nil))) | |
| 1010 (test-emacs-buffer-local-parameter nil) | |
| 1011 | |
| 1012 ;;----------------------------------------------------- | |
| 1013 ;; Test split-string | |
| 1014 ;;----------------------------------------------------- | |
| 1425 | 1015 ;; Keep nulls, explicit SEPARATORS |
| 1016 ;; Hrvoje didn't like the next 3 tests so I'm disabling them for now. -sb | |
| 1017 ;; I assume Hrvoje worried about the possibility of infloops. -sjt | |
| 1018 (when test-harness-risk-infloops | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1019 (Assert-equal (split-string "foo" "") '("" "f" "o" "o" "")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1020 (Assert-equal (split-string "foo" "^") '("" "foo")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1021 (Assert-equal (split-string "foo" "$") '("foo" ""))) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1022 (Assert-equal (split-string "foo,bar" ",") '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1023 (Assert-equal (split-string ",foo,bar," ",") '("" "foo" "bar" "")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1024 (Assert-equal (split-string ",foo,bar," "^,") '("" "foo,bar,")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1025 (Assert-equal (split-string ",foo,bar," ",$") '(",foo,bar" "")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1026 (Assert-equal (split-string ",foo,,bar," ",") '("" "foo" "" "bar" "")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1027 (Assert-equal (split-string "foo,,,bar" ",") '("foo" "" "" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1028 (Assert-equal (split-string "foo,,bar,," ",") '("foo" "" "bar" "" "")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1029 (Assert-equal (split-string "foo,,bar" ",+") '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1030 (Assert-equal (split-string ",foo,,bar," ",+") '("" "foo" "bar" "")) |
| 1425 | 1031 ;; Omit nulls, explicit SEPARATORS |
| 1032 (when test-harness-risk-infloops | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1033 (Assert-equal (split-string "foo" "" t) '("f" "o" "o")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1034 (Assert-equal (split-string "foo" "^" t) '("foo")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1035 (Assert-equal (split-string "foo" "$" t) '("foo"))) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1036 (Assert-equal (split-string "foo,bar" "," t) '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1037 (Assert-equal (split-string ",foo,bar," "," t) '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1038 (Assert-equal (split-string ",foo,bar," "^," t) '("foo,bar,")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1039 (Assert-equal (split-string ",foo,bar," ",$" t) '(",foo,bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1040 (Assert-equal (split-string ",foo,,bar," "," t) '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1041 (Assert-equal (split-string "foo,,,bar" "," t) '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1042 (Assert-equal (split-string "foo,,bar,," "," t) '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1043 (Assert-equal (split-string "foo,,bar" ",+" t) '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1044 (Assert-equal (split-string ",foo,,bar," ",+" t) '("foo" "bar")) |
| 1425 | 1045 ;; "Double-default" case |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1046 (Assert-equal (split-string "foo bar") '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1047 (Assert-equal (split-string " foo bar ") '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1048 (Assert-equal (split-string " foo bar ") '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1049 (Assert-equal (split-string "foo bar") '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1050 (Assert-equal (split-string "foo bar ") '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1051 (Assert-equal (split-string "foobar") '("foobar")) |
| 1425 | 1052 ;; Semantics are identical to "double-default" case! Fool ya? |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1053 (Assert-equal (split-string "foo bar" nil t) '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1054 (Assert-equal (split-string " foo bar " nil t) '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1055 (Assert-equal (split-string " foo bar " nil t) '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1056 (Assert-equal (split-string "foo bar" nil t) '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1057 (Assert-equal (split-string "foo bar " nil t) '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1058 (Assert-equal (split-string "foobar" nil t) '("foobar")) |
| 1425 | 1059 ;; Perverse "anti-double-default" case |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1060 (Assert-equal (split-string "foo bar" split-string-default-separators) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1061 '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1062 (Assert-equal (split-string " foo bar " split-string-default-separators) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1063 '("" "foo" "bar" "")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1064 (Assert-equal (split-string " foo bar " split-string-default-separators) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1065 '("" "foo" "bar" "")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1066 (Assert-equal (split-string "foo bar" split-string-default-separators) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1067 '("foo" "bar")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1068 (Assert-equal (split-string "foo bar " split-string-default-separators) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1069 '("foo" "bar" "")) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1070 (Assert-equal (split-string "foobar" split-string-default-separators) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1071 '("foobar")) |
| 434 | 1072 |
| 1073 ;;----------------------------------------------------- | |
| 1074 ;; Test near-text buffer functions. | |
| 1075 ;;----------------------------------------------------- | |
| 1076 (with-temp-buffer | |
| 1077 (erase-buffer) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1078 (Assert-eq (char-before) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1079 (Assert-eq (char-before (point)) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1080 (Assert-eq (char-before (point-marker)) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1081 (Assert-eq (char-before (point) (current-buffer)) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1082 (Assert-eq (char-before (point-marker) (current-buffer)) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1083 (Assert-eq (char-after) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1084 (Assert-eq (char-after (point)) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1085 (Assert-eq (char-after (point-marker)) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1086 (Assert-eq (char-after (point) (current-buffer)) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1087 (Assert-eq (char-after (point-marker) (current-buffer)) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1088 (Assert-eq (preceding-char) 0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1089 (Assert-eq (preceding-char (current-buffer)) 0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1090 (Assert-eq (following-char) 0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1091 (Assert-eq (following-char (current-buffer)) 0) |
| 434 | 1092 (insert "foobar") |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1093 (Assert-eq (char-before) ?r) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1094 (Assert-eq (char-after) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1095 (Assert-eq (preceding-char) ?r) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1096 (Assert-eq (following-char) 0) |
| 434 | 1097 (goto-char (point-min)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1098 (Assert-eq (char-before) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1099 (Assert-eq (char-after) ?f) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1100 (Assert-eq (preceding-char) 0) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1101 (Assert-eq (following-char) ?f) |
| 434 | 1102 ) |
| 440 | 1103 |
| 1104 ;;----------------------------------------------------- | |
| 1105 ;; Test plist manipulation functions. | |
| 1106 ;;----------------------------------------------------- | |
| 1107 (let ((sym (make-symbol "test-symbol"))) | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1108 (Assert-eq t (get* sym t t)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1109 (Assert-eq t (get sym t t)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1110 (Assert-eq t (getf nil t t)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1111 (Assert-eq t (plist-get nil t t)) |
| 440 | 1112 (put sym 'bar 'baz) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1113 (Assert-eq 'baz (get sym 'bar)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1114 (Assert-eq 'baz (getf '(bar baz) 'bar)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1115 (Assert-eq 'baz (getf (symbol-plist sym) 'bar)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1116 (Assert-eq 2 (getf '(1 2) 1)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1117 (Assert-eq 4 (put sym 3 4)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1118 (Assert-eq 4 (get sym 3)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1119 (Assert-eq t (remprop sym 3)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1120 (Assert-eq nil (remprop sym 3)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1121 (Assert-eq 5 (get sym 3 5)) |
| 440 | 1122 ) |
| 442 | 1123 |
| 1124 (loop for obj in | |
| 1125 (list (make-symbol "test-symbol") | |
| 1126 "test-string" | |
| 1127 (make-extent nil nil nil) | |
| 1128 (make-face 'test-face)) | |
| 1129 do | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1130 (Assert-eq 2 (get obj ?1 2) obj) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1131 (Assert-eq 4 (put obj ?3 4) obj) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1132 (Assert-eq 4 (get obj ?3) obj) |
| 442 | 1133 (when (or (stringp obj) (symbolp obj)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1134 (Assert-equal '(?3 4) (object-plist obj) obj)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1135 (Assert-eq t (remprop obj ?3) obj) |
| 442 | 1136 (when (or (stringp obj) (symbolp obj)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1137 (Assert-eq '() (object-plist obj) obj)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1138 (Assert-eq nil (remprop obj ?3) obj) |
| 442 | 1139 (when (or (stringp obj) (symbolp obj)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1140 (Assert-eq '() (object-plist obj) obj)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1141 (Assert-eq 5 (get obj ?3 5) obj) |
| 442 | 1142 ) |
| 1143 | |
| 1144 (Check-Error-Message | |
| 1145 error "Object type has no properties" | |
| 1146 (get 2 'property)) | |
| 1147 | |
| 1148 (Check-Error-Message | |
| 1149 error "Object type has no settable properties" | |
| 1150 (put (current-buffer) 'property 'value)) | |
| 1151 | |
| 1152 (Check-Error-Message | |
| 1153 error "Object type has no removable properties" | |
| 1154 (remprop ?3 'property)) | |
| 1155 | |
| 1156 (Check-Error-Message | |
| 1157 error "Object type has no properties" | |
| 1158 (object-plist (symbol-function 'car))) | |
| 1159 | |
| 1160 (Check-Error-Message | |
| 1161 error "Can't remove property from object" | |
| 1162 (remprop (make-extent nil nil nil) 'detachable)) | |
| 1163 | |
| 1164 ;;----------------------------------------------------- | |
| 1165 ;; Test subseq | |
| 1166 ;;----------------------------------------------------- | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1167 (Assert-equal (subseq nil 0) nil) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1168 (Assert-equal (subseq [1 2 3] 0) [1 2 3]) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1169 (Assert-equal (subseq [1 2 3] 1 -1) [2]) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1170 (Assert-equal (subseq "123" 0) "123") |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1171 (Assert-equal (subseq "1234" -3 -1) "23") |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1172 (Assert-equal (subseq #*0011 0) #*0011) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1173 (Assert-equal (subseq #*0011 -3 3) #*01) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1174 (Assert-equal (subseq '(1 2 3) 0) '(1 2 3)) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1175 (Assert-equal (subseq '(1 2 3 4) -3 nil) '(2 3 4)) |
| 442 | 1176 |
| 446 | 1177 (Check-Error wrong-type-argument (subseq 3 2)) |
| 1178 (Check-Error args-out-of-range (subseq [1 2 3] -42)) | |
| 1179 (Check-Error args-out-of-range (subseq [1 2 3] 0 42)) | |
| 442 | 1180 |
| 1181 ;;----------------------------------------------------- | |
| 1182 ;; Time-related tests | |
| 1183 ;;----------------------------------------------------- | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1184 (Assert= (length (current-time-string)) 24) |
| 444 | 1185 |
| 1186 ;;----------------------------------------------------- | |
| 1187 ;; format test | |
| 1188 ;;----------------------------------------------------- | |
| 1189 (Assert (string= (format "%d" 10) "10")) | |
| 1190 (Assert (string= (format "%o" 8) "10")) | |
| 1191 (Assert (string= (format "%x" 31) "1f")) | |
| 1192 (Assert (string= (format "%X" 31) "1F")) | |
| 826 | 1193 ;; MS-Windows uses +002 in its floating-point numbers. #### We should |
| 1194 ;; perhaps fix this, but writing our own floating-point support in doprnt.c | |
| 1195 ;; is very hard. | |
| 1196 (Assert (or (string= (format "%e" 100) "1.000000e+02") | |
| 1197 (string= (format "%e" 100) "1.000000e+002"))) | |
| 1198 (Assert (or (string= (format "%E" 100) "1.000000E+02") | |
| 1199 (string= (format "%E" 100) "1.000000E+002"))) | |
| 1200 (Assert (or (string= (format "%E" 100) "1.000000E+02") | |
| 1201 (string= (format "%E" 100) "1.000000E+002"))) | |
| 444 | 1202 (Assert (string= (format "%f" 100) "100.000000")) |
| 448 | 1203 (Assert (string= (format "%7.3f" 12.12345) " 12.123")) |
| 1204 (Assert (string= (format "%07.3f" 12.12345) "012.123")) | |
| 1205 (Assert (string= (format "%-7.3f" 12.12345) "12.123 ")) | |
| 1206 (Assert (string= (format "%-07.3f" 12.12345) "12.123 ")) | |
| 444 | 1207 (Assert (string= (format "%g" 100.0) "100")) |
| 826 | 1208 (Assert (or (string= (format "%g" 0.000001) "1e-06") |
| 1209 (string= (format "%g" 0.000001) "1e-006"))) | |
| 444 | 1210 (Assert (string= (format "%g" 0.0001) "0.0001")) |
| 1211 (Assert (string= (format "%G" 100.0) "100")) | |
| 826 | 1212 (Assert (or (string= (format "%G" 0.000001) "1E-06") |
| 1213 (string= (format "%G" 0.000001) "1E-006"))) | |
| 444 | 1214 (Assert (string= (format "%G" 0.0001) "0.0001")) |
| 1215 | |
| 1216 (Assert (string= (format "%2$d%1$d" 10 20) "2010")) | |
| 1217 (Assert (string= (format "%-d" 10) "10")) | |
| 1218 (Assert (string= (format "%-4d" 10) "10 ")) | |
| 1219 (Assert (string= (format "%+d" 10) "+10")) | |
| 1220 (Assert (string= (format "%+d" -10) "-10")) | |
| 1221 (Assert (string= (format "%+4d" 10) " +10")) | |
| 1222 (Assert (string= (format "%+4d" -10) " -10")) | |
| 1223 (Assert (string= (format "% d" 10) " 10")) | |
| 1224 (Assert (string= (format "% d" -10) "-10")) | |
| 1225 (Assert (string= (format "% 4d" 10) " 10")) | |
| 1226 (Assert (string= (format "% 4d" -10) " -10")) | |
| 1227 (Assert (string= (format "%0d" 10) "10")) | |
| 1228 (Assert (string= (format "%0d" -10) "-10")) | |
| 1229 (Assert (string= (format "%04d" 10) "0010")) | |
| 1230 (Assert (string= (format "%04d" -10) "-010")) | |
| 1231 (Assert (string= (format "%*d" 4 10) " 10")) | |
| 1232 (Assert (string= (format "%*d" 4 -10) " -10")) | |
| 1233 (Assert (string= (format "%*d" -4 10) "10 ")) | |
| 1234 (Assert (string= (format "%*d" -4 -10) "-10 ")) | |
| 1235 (Assert (string= (format "%#d" 10) "10")) | |
| 1236 (Assert (string= (format "%#o" 8) "010")) | |
| 1237 (Assert (string= (format "%#x" 16) "0x10")) | |
| 826 | 1238 (Assert (or (string= (format "%#e" 100) "1.000000e+02") |
| 1239 (string= (format "%#e" 100) "1.000000e+002"))) | |
| 1240 (Assert (or (string= (format "%#E" 100) "1.000000E+02") | |
| 1241 (string= (format "%#E" 100) "1.000000E+002"))) | |
| 444 | 1242 (Assert (string= (format "%#f" 100) "100.000000")) |
| 1243 (Assert (string= (format "%#g" 100.0) "100.000")) | |
| 826 | 1244 (Assert (or (string= (format "%#g" 0.000001) "1.00000e-06") |
| 1245 (string= (format "%#g" 0.000001) "1.00000e-006"))) | |
| 444 | 1246 (Assert (string= (format "%#g" 0.0001) "0.000100000")) |
| 1247 (Assert (string= (format "%#G" 100.0) "100.000")) | |
| 826 | 1248 (Assert (or (string= (format "%#G" 0.000001) "1.00000E-06") |
| 1249 (string= (format "%#G" 0.000001) "1.00000E-006"))) | |
| 444 | 1250 (Assert (string= (format "%#G" 0.0001) "0.000100000")) |
| 1251 (Assert (string= (format "%.1d" 10) "10")) | |
| 1252 (Assert (string= (format "%.4d" 10) "0010")) | |
| 1253 ;; Combination of `-', `+', ` ', `0', `#', `.', `*' | |
| 448 | 1254 (Assert (string= (format "%-04d" 10) "10 ")) |
| 444 | 1255 (Assert (string= (format "%-*d" 4 10) "10 ")) |
| 1256 ;; #### Correctness of this behavior is questionable. | |
| 1257 ;; It might be better to signal error. | |
| 1258 (Assert (string= (format "%-*d" -4 10) "10 ")) | |
| 1259 ;; These behavior is not specified. | |
| 1260 ;; (format "%-+d" 10) | |
| 1261 ;; (format "%- d" 10) | |
| 1262 ;; (format "%-01d" 10) | |
| 1263 ;; (format "%-#4x" 10) | |
| 1264 ;; (format "%-.1d" 10) | |
| 1265 | |
| 1266 (Assert (string= (format "%01.1d" 10) "10")) | |
| 448 | 1267 (Assert (string= (format "%03.1d" 10) " 10")) |
| 1268 (Assert (string= (format "%01.3d" 10) "010")) | |
| 1269 (Assert (string= (format "%1.3d" 10) "010")) | |
| 444 | 1270 (Assert (string= (format "%3.1d" 10) " 10")) |
| 446 | 1271 |
| 448 | 1272 ;;; The following two tests used to use 1000 instead of 100, |
| 1273 ;;; but that merely found buffer overflow bugs in Solaris sprintf(). | |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1274 (Assert= 102 (length (format "%.100f" 3.14))) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1275 (Assert= 100 (length (format "%100f" 3.14))) |
| 448 | 1276 |
| 446 | 1277 ;;; Check for 64-bit cleanness on LP64 platforms. |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1278 (Assert= (read (format "%d" most-positive-fixnum)) most-positive-fixnum) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1279 (Assert= (read (format "%ld" most-positive-fixnum)) most-positive-fixnum) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1280 (Assert= (read (format "%u" most-positive-fixnum)) most-positive-fixnum) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1281 (Assert= (read (format "%lu" most-positive-fixnum)) most-positive-fixnum) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1282 (Assert= (read (format "%d" most-negative-fixnum)) most-negative-fixnum) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1283 (Assert= (read (format "%ld" most-negative-fixnum)) most-negative-fixnum) |
| 446 | 1284 |
| 4287 | 1285 ;; These used to crash. |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1286 (Assert-eql (read (format "%f" 1.2e+302)) 1.2e+302) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1287 (Assert-eql (read (format "%.1000d" 1)) 1) |
| 4287 | 1288 |
| 446 | 1289 ;;; "%u" is undocumented, and Emacs Lisp has no unsigned type. |
| 1290 ;;; What to do if "%u" is used with a negative number? | |
| 1983 | 1291 ;;; For non-bignum XEmacsen, the most reasonable thing seems to be to print an |
| 1292 ;;; un-read-able number. The printed value might be useful to a human, if not | |
| 1293 ;;; to Emacs Lisp. | |
| 1294 ;;; For bignum XEmacsen, we make %u with a negative value throw an error. | |
| 1295 (if (featurep 'bignum) | |
| 1296 (progn | |
| 1297 (Check-Error wrong-type-argument (format "%u" most-negative-fixnum)) | |
| 1298 (Check-Error wrong-type-argument (format "%u" -1))) | |
| 1299 (Check-Error invalid-read-syntax (read (format "%u" most-negative-fixnum))) | |
| 1300 (Check-Error invalid-read-syntax (read (format "%u" -1)))) | |
| 448 | 1301 |
| 1302 ;; Check all-completions ignore element start with space. | |
| 1303 (Assert (not (all-completions "" '((" hidden" . "object"))))) | |
| 1304 (Assert (all-completions " " '((" hidden" . "object")))) | |
|
4394
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1305 |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1306 (let* ((literal-with-uninterned |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1307 '(first-element |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1308 [#1=#:G32976 #2=#:G32974 #3=#:G32971 #4=#:G32969 alias |
|
4396
e97f16fb2e25
Don't assume lisp-tests.el will be correctly read as UTF-8.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4394
diff
changeset
|
1309 #s(hash-table size 256 data (969 ?\xF9 55 ?7 166 ?\xA6)) |
|
4394
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1310 #5=#:G32970 #6=#:G32972])) |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1311 (print-readably t) |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1312 (print-gensym t) |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1313 (printed-with-uninterned (prin1-to-string literal-with-uninterned)) |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1314 (awkward-regexp "#1=#") |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1315 (first-match-start (string-match awkward-regexp |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1316 printed-with-uninterned))) |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1317 (Assert (null (string-match awkward-regexp printed-with-uninterned |
|
cacc942c0d0f
Avoid clearing print-gensym-alist inappropriately when printing hash tables.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4287
diff
changeset
|
1318 (1+ first-match-start))))) |
|
4580
1d11ecca9cd0
Print char table values correctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4575
diff
changeset
|
1319 |
|
1d11ecca9cd0
Print char table values correctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4575
diff
changeset
|
1320 (let ((char-table-with-string #s(char-table data (?\x00 "text"))) |
|
1d11ecca9cd0
Print char table values correctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4575
diff
changeset
|
1321 (char-table-with-symbol #s(char-table data (?\x00 text)))) |
|
4582
00ed9903a988
Fix make check after my last change.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4580
diff
changeset
|
1322 (Assert (not (string-equal (prin1-to-string char-table-with-string) |
|
00ed9903a988
Fix make check after my last change.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4580
diff
changeset
|
1323 (prin1-to-string char-table-with-symbol))) |
|
4580
1d11ecca9cd0
Print char table values correctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4575
diff
changeset
|
1324 "Check that char table elements are quoted correctly when printing")) |
|
1d11ecca9cd0
Print char table values correctly.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4575
diff
changeset
|
1325 |
|
4608
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1326 |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1327 (let ((test-file-name |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1328 (make-temp-file (expand-file-name "sR4KDwU" (temp-directory)) |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1329 nil ".el"))) |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1330 (find-file test-file-name) |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1331 (erase-buffer) |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1332 (insert |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1333 "\ |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1334 ;; Lisp should not be able to modify #$, which is |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1335 ;; Vload_file_name_internal of lread.c. |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1336 (Check-Error setting-constant (aset #$ 0 ?\\ )) |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1337 |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1338 ;; But modifying load-file-name should work: |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1339 (let ((new-char ?\\ ) |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1340 old-char) |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1341 (setq old-char (aref load-file-name 0)) |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1342 (if (= new-char old-char) |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1343 (setq new-char ?/)) |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1344 (aset load-file-name 0 new-char) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1345 (Assert= new-char (aref load-file-name 0) |
|
4608
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1346 \"Check that we can modify the string value of load-file-name\")) |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1347 |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1348 (let* ((new-load-file-name \"hi there\") |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1349 (load-file-name new-load-file-name)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1350 (Assert-eq new-load-file-name load-file-name |
|
4608
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1351 \"Checking that we can bind load-file-name successfully.\")) |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1352 |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1353 ") |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1354 (write-region (point-min) (point-max) test-file-name nil 'quiet) |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1355 (set-buffer-modified-p nil) |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1356 (kill-buffer nil) |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1357 (load test-file-name nil t nil) |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1358 (delete-file test-file-name)) |
|
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1359 |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1360 (flet ((cl-floor (x &optional y) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1361 (let ((q (floor x y))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1362 (list q (- x (if y (* y q) q))))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1363 (cl-ceiling (x &optional y) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1364 (let ((res (cl-floor x y))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1365 (if (= (car (cdr res)) 0) res |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1366 (list (1+ (car res)) (- (car (cdr res)) (or y 1)))))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1367 (cl-truncate (x &optional y) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1368 (if (eq (>= x 0) (or (null y) (>= y 0))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1369 (cl-floor x y) (cl-ceiling x y))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1370 (cl-round (x &optional y) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1371 (if y |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1372 (if (and (integerp x) (integerp y)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1373 (let* ((hy (/ y 2)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1374 (res (cl-floor (+ x hy) y))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1375 (if (and (= (car (cdr res)) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1376 (= (+ hy hy) y) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1377 (/= (% (car res) 2) 0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1378 (list (1- (car res)) hy) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1379 (list (car res) (- (car (cdr res)) hy)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1380 (let ((q (round (/ x y)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1381 (list q (- x (* q y))))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1382 (if (integerp x) (list x 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1383 (let ((q (round x))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1384 (list q (- x q)))))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1385 (Assert-rounding (first second &key |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1386 one-floor-result two-floor-result |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1387 one-ffloor-result two-ffloor-result |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1388 one-ceiling-result two-ceiling-result |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1389 one-fceiling-result two-fceiling-result |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1390 one-round-result two-round-result |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1391 one-fround-result two-fround-result |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1392 one-truncate-result two-truncate-result |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1393 one-ftruncate-result two-ftruncate-result) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1394 (Assert-equal one-floor-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1395 (floor first)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1396 (format "checking (floor %S) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1397 first one-floor-result)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1398 (Assert-equal one-floor-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1399 (floor first 1)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1400 (format "checking (floor %S 1) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1401 first one-floor-result)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1402 (Check-Error arith-error (floor first 0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1403 (Check-Error arith-error (floor first 0.0)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1404 (Assert-equal two-floor-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1405 (floor first second)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1406 (format |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1407 "checking (floor %S %S) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1408 first second two-floor-result)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1409 (Assert-equal (cl-floor first second) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1410 (multiple-value-list (floor first second)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1411 (format |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1412 "checking (floor %S %S) gives the same as the old code" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1413 first second)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1414 (Assert-equal one-ffloor-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1415 (ffloor first)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1416 (format "checking (ffloor %S) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1417 first one-ffloor-result)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1418 (Assert-equal one-ffloor-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1419 (ffloor first 1)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1420 (format "checking (ffloor %S 1) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1421 first one-ffloor-result)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1422 (Check-Error arith-error (ffloor first 0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1423 (Check-Error arith-error (ffloor first 0.0)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1424 (Assert-equal two-ffloor-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1425 (ffloor first second)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1426 (format "checking (ffloor %S %S) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1427 first second two-ffloor-result)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1428 (Assert-equal one-ceiling-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1429 (ceiling first)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1430 (format "checking (ceiling %S) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1431 first one-ceiling-result)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1432 (Assert-equal one-ceiling-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1433 (ceiling first 1)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1434 (format "checking (ceiling %S 1) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1435 first one-ceiling-result)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1436 (Check-Error arith-error (ceiling first 0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1437 (Check-Error arith-error (ceiling first 0.0)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1438 (Assert-equal two-ceiling-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1439 (ceiling first second)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1440 (format "checking (ceiling %S %S) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1441 first second two-ceiling-result)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1442 (Assert-equal (cl-ceiling first second) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1443 (multiple-value-list (ceiling first second)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1444 (format |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1445 "checking (ceiling %S %S) gives the same as the old code" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1446 first second)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1447 (Assert-equal one-fceiling-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1448 (fceiling first)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1449 (format "checking (fceiling %S) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1450 first one-fceiling-result)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1451 (Assert-equal one-fceiling-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1452 (fceiling first 1)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1453 (format "checking (fceiling %S 1) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1454 first one-fceiling-result)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1455 (Check-Error arith-error (fceiling first 0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1456 (Check-Error arith-error (fceiling first 0.0)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1457 (Assert-equal two-fceiling-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1458 (fceiling first second)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1459 (format "checking (fceiling %S %S) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1460 first second two-fceiling-result)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1461 (Assert-equal one-round-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1462 (round first)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1463 (format "checking (round %S) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1464 first one-round-result)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1465 (Assert-equal one-round-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1466 (round first 1)) |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4679
diff
changeset
|
1467 (format "checking (round %S 1) gives %S" |
|
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4679
diff
changeset
|
1468 first one-round-result)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1469 (Check-Error arith-error (round first 0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1470 (Check-Error arith-error (round first 0.0)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1471 (Assert-equal two-round-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1472 (round first second)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1473 (format "checking (round %S %S) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1474 first second two-round-result)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1475 (Assert-equal one-fround-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1476 (fround first)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1477 (format "checking (fround %S) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1478 first one-fround-result)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1479 (Assert-equal one-fround-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1480 (fround first 1)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1481 (format "checking (fround %S 1) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1482 first one-fround-result)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1483 (Check-Error arith-error (fround first 0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1484 (Check-Error arith-error (fround first 0.0)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1485 (Assert-equal two-fround-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1486 (fround first second)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1487 (format "checking (fround %S %S) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1488 first second two-fround-result)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1489 (Assert-equal (cl-round first second) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1490 (multiple-value-list (round first second)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1491 (format |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1492 "checking (round %S %S) gives the same as the old code" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1493 first second)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1494 (Assert-equal one-truncate-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1495 (truncate first)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1496 (format "checking (truncate %S) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1497 first one-truncate-result)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1498 (Assert-equal one-truncate-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1499 (truncate first 1)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1500 (format "checking (truncate %S 1) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1501 first one-truncate-result)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1502 (Check-Error arith-error (truncate first 0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1503 (Check-Error arith-error (truncate first 0.0)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1504 (Assert-equal two-truncate-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1505 (truncate first second)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1506 (format "checking (truncate %S %S) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1507 first second two-truncate-result)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1508 (Assert-equal (cl-truncate first second) |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1509 (multiple-value-list (truncate first second)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1510 (format |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1511 "checking (truncate %S %S) gives the same as the old code" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1512 first second)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1513 (Assert-equal one-ftruncate-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1514 (ftruncate first)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1515 (format "checking (ftruncate %S) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1516 first one-ftruncate-result)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1517 (Assert-equal one-ftruncate-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1518 (ftruncate first 1)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1519 (format "checking (ftruncate %S 1) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1520 first one-ftruncate-result)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1521 (Check-Error arith-error (ftruncate first 0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1522 (Check-Error arith-error (ftruncate first 0.0)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1523 (Assert-equal two-ftruncate-result (multiple-value-list |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1524 (ftruncate first second)) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1525 (format "checking (ftruncate %S %S) gives %S" |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1526 first second two-ftruncate-result))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1527 (Assert-rounding-floating (pie ee) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1528 (let ((pie-type (type-of pie))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1529 (assert (eq pie-type (type-of ee)) t |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1530 "This code assumes the two arguments have the same type.") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1531 (Assert-rounding pie ee |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1532 :one-floor-result (list 3 (- pie 3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1533 :two-floor-result (list 1 (- pie (* 1 ee))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1534 :one-ffloor-result (list (coerce 3 pie-type) (- pie 3.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1535 :two-ffloor-result (list (coerce 1 pie-type) (- pie (* 1.0 ee))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1536 :one-ceiling-result (list 4 (- pie 4)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1537 :two-ceiling-result (list 2 (- pie (* 2 ee))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1538 :one-fceiling-result (list (coerce 4 pie-type) (- pie 4.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1539 :two-fceiling-result (list (coerce 2 pie-type) (- pie (* 2.0 ee))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1540 :one-round-result (list 3 (- pie 3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1541 :two-round-result (list 1 (- pie (* 1 ee))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1542 :one-fround-result (list (coerce 3 pie-type) (- pie 3.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1543 :two-fround-result (list (coerce 1 pie-type) (- pie (* 1.0 ee))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1544 :one-truncate-result (list 3 (- pie 3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1545 :two-truncate-result (list 1 (- pie (* 1 ee))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1546 :one-ftruncate-result (list (coerce 3 pie-type) (- pie 3.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1547 :two-ftruncate-result (list (coerce 1 pie-type) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1548 (- pie (* 1.0 ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1549 (Assert-rounding pie (- ee) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1550 :one-floor-result (list 3 (- pie 3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1551 :two-floor-result (list -2 (- pie (* -2 (- ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1552 :one-ffloor-result (list (coerce 3 pie-type) (- pie 3.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1553 :two-ffloor-result (list (coerce -2 pie-type) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1554 (- pie (* -2.0 (- ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1555 :one-ceiling-result (list 4 (- pie 4)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1556 :two-ceiling-result (list -1 (- pie (* -1 (- ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1557 :one-fceiling-result (list (coerce 4 pie-type) (- pie 4.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1558 :two-fceiling-result (list (coerce -1 pie-type) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1559 (- pie (* -1.0 (- ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1560 :one-round-result (list 3 (- pie 3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1561 :two-round-result (list -1 (- pie (* -1 (- ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1562 :one-fround-result (list (coerce 3 pie-type) (- pie 3.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1563 :two-fround-result (list (coerce -1 pie-type) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1564 (- pie (* -1.0 (- ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1565 :one-truncate-result (list 3 (- pie 3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1566 :two-truncate-result (list -1 (- pie (* -1 (- ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1567 :one-ftruncate-result (list (coerce 3 pie-type) (- pie 3.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1568 :two-ftruncate-result (list (coerce -1 pie-type) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1569 (- pie (* -1.0 (- ee))))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1570 (Assert-rounding (- pie) ee |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1571 :one-floor-result (list -4 (- (- pie) -4)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1572 :two-floor-result (list -2 (- (- pie) (* -2 ee))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1573 :one-ffloor-result (list (coerce -4 pie-type) (- (- pie) -4.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1574 :two-ffloor-result (list (coerce -2 pie-type) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1575 (- (- pie) (* -2.0 ee))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1576 :one-ceiling-result (list -3 (- (- pie) -3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1577 :two-ceiling-result (list -1 (- (- pie) (* -1 ee))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1578 :one-fceiling-result (list (coerce -3 pie-type) (- (- pie) -3.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1579 :two-fceiling-result (list (coerce -1 pie-type) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1580 (- (- pie) (* -1.0 ee))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1581 :one-round-result (list -3 (- (- pie) -3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1582 :two-round-result (list -1 (- (- pie) (* -1 ee))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1583 :one-fround-result (list (coerce -3 pie-type) (- (- pie) -3.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1584 :two-fround-result (list (coerce -1 pie-type) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1585 (- (- pie) (* -1.0 ee))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1586 :one-truncate-result (list -3 (- (- pie) -3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1587 :two-truncate-result (list -1 (- (- pie) (* -1 ee))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1588 :one-ftruncate-result (list (coerce -3 pie-type) (- (- pie) -3.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1589 :two-ftruncate-result (list (coerce -1 pie-type) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1590 (- (- pie) (* -1.0 ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1591 (Assert-rounding (- pie) (- ee) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1592 :one-floor-result (list -4 (- (- pie) -4)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1593 :two-floor-result (list 1 (- (- pie) (* 1 (- ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1594 :one-ffloor-result (list (coerce -4 pie-type) (- (- pie) -4.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1595 :two-ffloor-result (list (coerce 1 pie-type) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1596 (- (- pie) (* 1.0 (- ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1597 :one-ceiling-result (list -3 (- (- pie) -3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1598 :two-ceiling-result (list 2 (- (- pie) (* 2 (- ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1599 :one-fceiling-result (list (coerce -3 pie-type) (- (- pie) -3.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1600 :two-fceiling-result (list (coerce 2 pie-type) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1601 (- (- pie) (* 2.0 (- ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1602 :one-round-result (list -3 (- (- pie) -3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1603 :two-round-result (list 1 (- (- pie) (* 1 (- ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1604 :one-fround-result (list (coerce -3 pie-type) (- (- pie) -3.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1605 :two-fround-result (list (coerce 1 pie-type) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1606 (- (- pie) (* 1.0 (- ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1607 :one-truncate-result (list -3 (- (- pie) -3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1608 :two-truncate-result (list 1 (- (- pie) (* 1 (- ee)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1609 :one-ftruncate-result (list (coerce -3 pie-type) (- (- pie) -3.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1610 :two-ftruncate-result (list (coerce 1 pie-type) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1611 (- (- pie) (* 1.0 (- ee))))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1612 (Assert-rounding ee pie |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1613 :one-floor-result (list 2 (- ee 2)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1614 :two-floor-result (list 0 ee) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1615 :one-ffloor-result (list (coerce 2 pie-type) (- ee 2.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1616 :two-ffloor-result (list (coerce 0 pie-type) ee) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1617 :one-ceiling-result (list 3 (- ee 3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1618 :two-ceiling-result (list 1 (- ee pie)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1619 :one-fceiling-result (list (coerce 3 pie-type) (- ee 3.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1620 :two-fceiling-result (list (coerce 1 pie-type) (- ee pie)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1621 :one-round-result (list 3 (- ee 3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1622 :two-round-result (list 1 (- ee (* 1 pie))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1623 :one-fround-result (list (coerce 3 pie-type) (- ee 3.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1624 :two-fround-result (list (coerce 1 pie-type) (- ee (* 1.0 pie))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1625 :one-truncate-result (list 2 (- ee 2)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1626 :two-truncate-result (list 0 ee) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1627 :one-ftruncate-result (list (coerce 2 pie-type) (- ee 2.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1628 :two-ftruncate-result (list (coerce 0 pie-type) ee)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1629 (Assert-rounding ee (- pie) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1630 :one-floor-result (list 2 (- ee 2)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1631 :two-floor-result (list -1 (- ee (* -1 (- pie)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1632 :one-ffloor-result (list (coerce 2 pie-type) (- ee 2.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1633 :two-ffloor-result (list (coerce -1 pie-type) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1634 (- ee (* -1.0 (- pie)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1635 :one-ceiling-result (list 3 (- ee 3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1636 :two-ceiling-result (list 0 ee) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1637 :one-fceiling-result (list (coerce 3 pie-type) (- ee 3.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1638 :two-fceiling-result (list (coerce 0 pie-type) ee) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1639 :one-round-result (list 3 (- ee 3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1640 :two-round-result (list -1 (- ee (* -1 (- pie)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1641 :one-fround-result (list (coerce 3 pie-type) (- ee 3.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1642 :two-fround-result (list (coerce -1 pie-type) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1643 (- ee (* -1.0 (- pie)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1644 :one-truncate-result (list 2 (- ee 2)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1645 :two-truncate-result (list 0 ee) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1646 :one-ftruncate-result (list (coerce 2 pie-type) (- ee 2.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1647 :two-ftruncate-result (list (coerce 0 pie-type) ee))))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1648 ;; First, two integers: |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1649 (Assert-rounding 27 8 :one-floor-result '(27 0) :two-floor-result '(3 3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1650 :one-ffloor-result '(27.0 0) :two-ffloor-result '(3.0 3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1651 :one-ceiling-result '(27 0) :two-ceiling-result '(4 -5) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1652 :one-fceiling-result '(27.0 0) :two-fceiling-result '(4.0 -5) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1653 :one-round-result '(27 0) :two-round-result '(3 3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1654 :one-fround-result '(27.0 0) :two-fround-result '(3.0 3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1655 :one-truncate-result '(27 0) :two-truncate-result '(3 3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1656 :one-ftruncate-result '(27.0 0) :two-ftruncate-result '(3.0 3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1657 (Assert-rounding 27 -8 :one-floor-result '(27 0) :two-floor-result '(-4 -5) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1658 :one-ffloor-result '(27.0 0) :two-ffloor-result '(-4.0 -5) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1659 :one-ceiling-result '(27 0) :two-ceiling-result '(-3 3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1660 :one-fceiling-result '(27.0 0) :two-fceiling-result '(-3.0 3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1661 :one-round-result '(27 0) :two-round-result '(-3 3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1662 :one-fround-result '(27.0 0) :two-fround-result '(-3.0 3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1663 :one-truncate-result '(27 0) :two-truncate-result '(-3 3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1664 :one-ftruncate-result '(27.0 0) :two-ftruncate-result '(-3.0 3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1665 (Assert-rounding -27 8 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1666 :one-floor-result '(-27 0) :two-floor-result '(-4 5) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1667 :one-ffloor-result '(-27.0 0) :two-ffloor-result '(-4.0 5) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1668 :one-ceiling-result '(-27 0) :two-ceiling-result '(-3 -3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1669 :one-fceiling-result '(-27.0 0) :two-fceiling-result '(-3.0 -3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1670 :one-round-result '(-27 0) :two-round-result '(-3 -3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1671 :one-fround-result '(-27.0 0) :two-fround-result '(-3.0 -3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1672 :one-truncate-result '(-27 0) :two-truncate-result '(-3 -3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1673 :one-ftruncate-result '(-27.0 0) :two-ftruncate-result '(-3.0 -3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1674 (Assert-rounding -27 -8 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1675 :one-floor-result '(-27 0) :two-floor-result '(3 -3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1676 :one-ffloor-result '(-27.0 0) :two-ffloor-result '(3.0 -3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1677 :one-ceiling-result '(-27 0) :two-ceiling-result '(4 5) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1678 :one-fceiling-result '(-27.0 0) :two-fceiling-result '(4.0 5) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1679 :one-round-result '(-27 0) :two-round-result '(3 -3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1680 :one-fround-result '(-27.0 0) :two-fround-result '(3.0 -3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1681 :one-truncate-result '(-27 0) :two-truncate-result '(3 -3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1682 :one-ftruncate-result '(-27.0 0) :two-ftruncate-result '(3.0 -3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1683 (Assert-rounding 8 27 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1684 :one-floor-result '(8 0) :two-floor-result '(0 8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1685 :one-ffloor-result '(8.0 0) :two-ffloor-result '(0.0 8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1686 :one-ceiling-result '(8 0) :two-ceiling-result '(1 -19) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1687 :one-fceiling-result '(8.0 0) :two-fceiling-result '(1.0 -19) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1688 :one-round-result '(8 0) :two-round-result '(0 8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1689 :one-fround-result '(8.0 0) :two-fround-result '(0.0 8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1690 :one-truncate-result '(8 0) :two-truncate-result '(0 8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1691 :one-ftruncate-result '(8.0 0) :two-ftruncate-result '(0.0 8)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1692 (Assert-rounding 8 -27 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1693 :one-floor-result '(8 0) :two-floor-result '(-1 -19) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1694 :one-ffloor-result '(8.0 0) :two-ffloor-result '(-1.0 -19) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1695 :one-ceiling-result '(8 0) :two-ceiling-result '(0 8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1696 :one-fceiling-result '(8.0 0) :two-fceiling-result '(0.0 8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1697 :one-round-result '(8 0) :two-round-result '(0 8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1698 :one-fround-result '(8.0 0) :two-fround-result '(0.0 8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1699 :one-truncate-result '(8 0) :two-truncate-result '(0 8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1700 :one-ftruncate-result '(8.0 0) :two-ftruncate-result '(0.0 8)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1701 (Assert-rounding -8 27 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1702 :one-floor-result '(-8 0) :two-floor-result '(-1 19) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1703 :one-ffloor-result '(-8.0 0) :two-ffloor-result '(-1.0 19) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1704 :one-ceiling-result '(-8 0) :two-ceiling-result '(0 -8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1705 :one-fceiling-result '(-8.0 0) :two-fceiling-result '(0.0 -8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1706 :one-round-result '(-8 0) :two-round-result '(0 -8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1707 :one-fround-result '(-8.0 0) :two-fround-result '(0.0 -8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1708 :one-truncate-result '(-8 0) :two-truncate-result '(0 -8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1709 :one-ftruncate-result '(-8.0 0) :two-ftruncate-result '(0.0 -8)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1710 (Assert-rounding -8 -27 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1711 :one-floor-result '(-8 0) :two-floor-result '(0 -8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1712 :one-ffloor-result '(-8.0 0) :two-ffloor-result '(0.0 -8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1713 :one-ceiling-result '(-8 0) :two-ceiling-result '(1 19) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1714 :one-fceiling-result '(-8.0 0) :two-fceiling-result '(1.0 19) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1715 :one-round-result '(-8 0) :two-round-result '(0 -8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1716 :one-fround-result '(-8.0 0) :two-fround-result '(0.0 -8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1717 :one-truncate-result '(-8 0) :two-truncate-result '(0 -8) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1718 :one-ftruncate-result '(-8.0 0) :two-ftruncate-result '(0.0 -8)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1719 (Assert-rounding 32 4 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1720 :one-floor-result '(32 0) :two-floor-result '(8 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1721 :one-ffloor-result '(32.0 0) :two-ffloor-result '(8.0 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1722 :one-ceiling-result '(32 0) :two-ceiling-result '(8 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1723 :one-fceiling-result '(32.0 0) :two-fceiling-result '(8.0 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1724 :one-round-result '(32 0) :two-round-result '(8 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1725 :one-fround-result '(32.0 0) :two-fround-result '(8.0 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1726 :one-truncate-result '(32 0) :two-truncate-result '(8 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1727 :one-ftruncate-result '(32.0 0) :two-ftruncate-result '(8.0 0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1728 (Assert-rounding 32 -4 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1729 :one-floor-result '(32 0) :two-floor-result '(-8 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1730 :one-ffloor-result '(32.0 0) :two-ffloor-result '(-8.0 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1731 :one-ceiling-result '(32 0) :two-ceiling-result '(-8 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1732 :one-fceiling-result '(32.0 0) :two-fceiling-result '(-8.0 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1733 :one-round-result '(32 0) :two-round-result '(-8 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1734 :one-fround-result '(32.0 0) :two-fround-result '(-8.0 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1735 :one-truncate-result '(32 0) :two-truncate-result '(-8 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1736 :one-ftruncate-result '(32.0 0) :two-ftruncate-result '(-8.0 0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1737 (Assert-rounding 12 9 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1738 :one-floor-result '(12 0) :two-floor-result '(1 3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1739 :one-ffloor-result '(12.0 0) :two-ffloor-result '(1.0 3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1740 :one-ceiling-result '(12 0) :two-ceiling-result '(2 -6) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1741 :one-fceiling-result '(12.0 0) :two-fceiling-result '(2.0 -6) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1742 :one-round-result '(12 0) :two-round-result '(1 3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1743 :one-fround-result '(12.0 0) :two-fround-result '(1.0 3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1744 :one-truncate-result '(12 0) :two-truncate-result '(1 3) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1745 :one-ftruncate-result '(12.0 0) :two-ftruncate-result '(1.0 3)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1746 (Assert-rounding 10 4 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1747 :one-floor-result '(10 0) :two-floor-result '(2 2) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1748 :one-ffloor-result '(10.0 0) :two-ffloor-result '(2.0 2) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1749 :one-ceiling-result '(10 0) :two-ceiling-result '(3 -2) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1750 :one-fceiling-result '(10.0 0) :two-fceiling-result '(3.0 -2) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1751 :one-round-result '(10 0) :two-round-result '(2 2) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1752 :one-fround-result '(10.0 0) :two-fround-result '(2.0 2) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1753 :one-truncate-result '(10 0) :two-truncate-result '(2 2) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1754 :one-ftruncate-result '(10.0 0) :two-ftruncate-result '(2.0 2)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1755 (Assert-rounding 14 4 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1756 :one-floor-result '(14 0) :two-floor-result '(3 2) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1757 :one-ffloor-result '(14.0 0) :two-ffloor-result '(3.0 2) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1758 :one-ceiling-result '(14 0) :two-ceiling-result '(4 -2) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1759 :one-fceiling-result '(14.0 0) :two-fceiling-result '(4.0 -2) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1760 :one-round-result '(14 0) :two-round-result '(4 -2) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1761 :one-fround-result '(14.0 0) :two-fround-result '(4.0 -2) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1762 :one-truncate-result '(14 0) :two-truncate-result '(3 2) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1763 :one-ftruncate-result '(14.0 0) :two-ftruncate-result '(3.0 2)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1764 ;; Now, two floats: |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1765 (Assert-rounding-floating pi e) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1766 (when (featurep 'bigfloat) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1767 (Assert-rounding-floating (coerce pi 'bigfloat) (coerce e 'bigfloat))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1768 (when (featurep 'bignum) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1769 (assert (not (evenp most-positive-fixnum)) t |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1770 "In the unlikely event that most-positive-fixnum is even, rewrite this.") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1771 (Assert-rounding (1+ most-positive-fixnum) (* 2 most-positive-fixnum) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1772 :one-floor-result `(,(1+ most-positive-fixnum) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1773 :two-floor-result `(0 ,(1+ most-positive-fixnum)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1774 :one-ffloor-result `(,(float (1+ most-positive-fixnum)) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1775 :two-ffloor-result `(0.0 ,(1+ most-positive-fixnum)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1776 :one-ceiling-result `(,(1+ most-positive-fixnum) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1777 :two-ceiling-result `(1 ,(1+ (- most-positive-fixnum))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1778 :one-fceiling-result `(,(float (1+ most-positive-fixnum)) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1779 :two-fceiling-result `(1.0 ,(1+ (- most-positive-fixnum))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1780 :one-round-result `(,(1+ most-positive-fixnum) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1781 :two-round-result `(1 ,(1+ (- most-positive-fixnum))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1782 :one-fround-result `(,(float (1+ most-positive-fixnum)) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1783 :two-fround-result `(1.0 ,(1+ (- most-positive-fixnum))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1784 :one-truncate-result `(,(1+ most-positive-fixnum) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1785 :two-truncate-result `(0 ,(1+ most-positive-fixnum)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1786 :one-ftruncate-result `(,(float (1+ most-positive-fixnum)) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1787 :two-ftruncate-result `(0.0 ,(1+ most-positive-fixnum))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1788 (Assert-rounding (1+ most-positive-fixnum) (- (* 2 most-positive-fixnum)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1789 :one-floor-result `(,(1+ most-positive-fixnum) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1790 :two-floor-result `(-1 ,(1+ (- most-positive-fixnum))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1791 :one-ffloor-result `(,(float (1+ most-positive-fixnum)) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1792 :two-ffloor-result `(-1.0 ,(1+ (- most-positive-fixnum))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1793 :one-ceiling-result `(,(1+ most-positive-fixnum) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1794 :two-ceiling-result `(0 ,(1+ most-positive-fixnum)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1795 :one-fceiling-result `(,(float (1+ most-positive-fixnum)) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1796 :two-fceiling-result `(0.0 ,(1+ most-positive-fixnum)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1797 :one-round-result `(,(1+ most-positive-fixnum) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1798 :two-round-result `(-1 ,(1+ (- most-positive-fixnum))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1799 :one-fround-result `(,(float (1+ most-positive-fixnum)) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1800 :two-fround-result `(-1.0 ,(1+ (- most-positive-fixnum))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1801 :one-truncate-result `(,(1+ most-positive-fixnum) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1802 :two-truncate-result `(0 ,(1+ most-positive-fixnum)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1803 :one-ftruncate-result `(,(float (1+ most-positive-fixnum)) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1804 :two-ftruncate-result `(0.0 ,(1+ most-positive-fixnum))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1805 (Assert-rounding (- (1+ most-positive-fixnum)) (* 2 most-positive-fixnum) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1806 :one-floor-result `(,(- (1+ most-positive-fixnum)) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1807 :two-floor-result `(-1 ,(1- most-positive-fixnum)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1808 :one-ffloor-result `(,(float (- (1+ most-positive-fixnum))) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1809 :two-ffloor-result `(-1.0 ,(1- most-positive-fixnum)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1810 :one-ceiling-result `(,(- (1+ most-positive-fixnum)) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1811 :two-ceiling-result `(0 ,(- (1+ most-positive-fixnum))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1812 :one-fceiling-result `(,(float (- (1+ most-positive-fixnum))) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1813 :two-fceiling-result `(0.0 ,(- (1+ most-positive-fixnum))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1814 :one-round-result `(,(- (1+ most-positive-fixnum)) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1815 :two-round-result `(-1 ,(1- most-positive-fixnum)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1816 :one-fround-result `(,(float (- (1+ most-positive-fixnum))) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1817 :two-fround-result `(-1.0 ,(1- most-positive-fixnum)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1818 :one-truncate-result `(,(- (1+ most-positive-fixnum)) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1819 :two-truncate-result `(0 ,(- (1+ most-positive-fixnum))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1820 :one-ftruncate-result `(,(float (- (1+ most-positive-fixnum))) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1821 :two-ftruncate-result `(0.0 ,(- (1+ most-positive-fixnum)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1822 ;; Test the handling of values with .5: |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1823 (Assert-rounding (1+ (* 2 most-positive-fixnum)) 2 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1824 :one-floor-result `(,(1+ (* 2 most-positive-fixnum)) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1825 :two-floor-result `(,most-positive-fixnum 1) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1826 :one-ffloor-result `(,(float (1+ (* 2 most-positive-fixnum))) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1827 ;; We can't just call #'float here; we must use code that converts a |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1828 ;; bignum with value most-positive-fixnum (the creation of which is |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1829 ;; not directly possible in Lisp) to a float, not code that converts |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1830 ;; the fixnum with value most-positive-fixnum to a float. The eval is |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1831 ;; to avoid compile-time optimisation that can break this. |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1832 :two-ffloor-result `(,(eval '(- (1+ most-positive-fixnum) 1 0.0)) 1) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1833 :one-ceiling-result `(,(1+ (* 2 most-positive-fixnum)) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1834 :two-ceiling-result `(,(1+ most-positive-fixnum) -1) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1835 :one-fceiling-result `(,(float (1+ (* 2 most-positive-fixnum))) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1836 :two-fceiling-result `(,(float (1+ most-positive-fixnum)) -1) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1837 :one-round-result `(,(1+ (* 2 most-positive-fixnum)) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1838 :two-round-result `(,(1+ most-positive-fixnum) -1) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1839 :one-fround-result `(,(float (1+ (* 2 most-positive-fixnum))) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1840 :two-fround-result `(,(float (1+ most-positive-fixnum)) -1) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1841 :one-truncate-result `(,(1+ (* 2 most-positive-fixnum)) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1842 :two-truncate-result `(,most-positive-fixnum 1) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1843 :one-ftruncate-result `(,(float (1+ (* 2 most-positive-fixnum))) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1844 ;; See the comment above on :two-ffloor-result: |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1845 :two-ftruncate-result `(,(eval '(- (1+ most-positive-fixnum) 1 0.0)) 1)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1846 (Assert-rounding (1+ (* 2 (1- most-positive-fixnum))) 2 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1847 :one-floor-result `(,(1+ (* 2 (1- most-positive-fixnum))) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1848 :two-floor-result `(,(1- most-positive-fixnum) 1) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1849 :one-ffloor-result `(,(float (1+ (* 2 (1- most-positive-fixnum)))) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1850 ;; See commentary above on float conversions. |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1851 :two-ffloor-result `(,(eval '(- (1+ most-positive-fixnum) 2 0.0)) 1) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1852 :one-ceiling-result `(,(1+ (* 2 (1- most-positive-fixnum))) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1853 :two-ceiling-result `(,most-positive-fixnum -1) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1854 :one-fceiling-result `(,(float (1+ (* 2 (1- most-positive-fixnum)))) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1855 :two-fceiling-result `(,(eval '(- (1+ most-positive-fixnum) 1 0.0)) -1) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1856 :one-round-result `(,(1+ (* 2 (1- most-positive-fixnum))) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1857 :two-round-result `(,(1- most-positive-fixnum) 1) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1858 :one-fround-result `(,(float (1+ (* 2 (1- most-positive-fixnum)))) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1859 :two-fround-result `(,(eval '(- (1+ most-positive-fixnum) 2 0.0)) 1) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1860 :one-truncate-result `(,(1+ (* 2 (1- most-positive-fixnum))) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1861 :two-truncate-result `(,(1- most-positive-fixnum) 1) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1862 :one-ftruncate-result `(,(float (1+ (* 2 (1- most-positive-fixnum)))) 0) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1863 ;; See commentary above |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1864 :two-ftruncate-result `(,(eval '(- (1+ most-positive-fixnum) 2 0.0)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1865 1))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1866 (when (featurep 'ratio) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1867 (Assert-rounding (read "4/3") (read "8/7") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1868 :one-floor-result '(1 1/3) :two-floor-result '(1 4/21) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1869 :one-ffloor-result '(1.0 1/3) :two-ffloor-result '(1.0 4/21) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1870 :one-ceiling-result '(2 -2/3) :two-ceiling-result '(2 -20/21) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1871 :one-fceiling-result '(2.0 -2/3) :two-fceiling-result '(2.0 -20/21) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1872 :one-round-result '(1 1/3) :two-round-result '(1 4/21) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1873 :one-fround-result '(1.0 1/3) :two-fround-result '(1.0 4/21) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1874 :one-truncate-result '(1 1/3) :two-truncate-result '(1 4/21) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1875 :one-ftruncate-result '(1.0 1/3) :two-ftruncate-result '(1.0 4/21)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1876 (Assert-rounding (read "-4/3") (read "8/7") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1877 :one-floor-result '(-2 2/3) :two-floor-result '(-2 20/21) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1878 :one-ffloor-result '(-2.0 2/3) :two-ffloor-result '(-2.0 20/21) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1879 :one-ceiling-result '(-1 -1/3) :two-ceiling-result '(-1 -4/21) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1880 :one-fceiling-result '(-1.0 -1/3) :two-fceiling-result '(-1.0 -4/21) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1881 :one-round-result '(-1 -1/3) :two-round-result '(-1 -4/21) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1882 :one-fround-result '(-1.0 -1/3) :two-fround-result '(-1.0 -4/21) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1883 :one-truncate-result '(-1 -1/3) :two-truncate-result '(-1 -4/21) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1884 :one-ftruncate-result '(-1.0 -1/3) :two-ftruncate-result '(-1.0 -4/21)))) |
|
4608
1e3cf11fa27d
Make #$ truly read-only for Lisp; check this in the test suite.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4582
diff
changeset
|
1885 |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1886 ;; Run this function in a Common Lisp with two arguments to get results that |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1887 ;; we should compare against, above. Though note the dancing-around with the |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1888 ;; bigfloats and bignums above, too; you can't necessarily just use the |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1889 ;; output here. |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1890 |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1891 (defun generate-rounding-output (first second) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1892 (let ((print-readably t)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1893 (princ first) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1894 (princ " ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1895 (princ second) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1896 (princ " :one-floor-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1897 (princ (list 'quote (multiple-value-list (floor first)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1898 (princ " :two-floor-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1899 (princ (list 'quote (multiple-value-list (floor first second)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1900 (princ " :one-ffloor-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1901 (princ (list 'quote (multiple-value-list (ffloor first)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1902 (princ " :two-ffloor-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1903 (princ (list 'quote (multiple-value-list (ffloor first second)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1904 (princ " :one-ceiling-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1905 (princ (list 'quote (multiple-value-list (ceiling first)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1906 (princ " :two-ceiling-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1907 (princ (list 'quote (multiple-value-list (ceiling first second)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1908 (princ " :one-fceiling-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1909 (princ (list 'quote (multiple-value-list (fceiling first)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1910 (princ " :two-fceiling-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1911 (princ (list 'quote (multiple-value-list (fceiling first second)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1912 (princ " :one-round-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1913 (princ (list 'quote (multiple-value-list (round first)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1914 (princ " :two-round-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1915 (princ (list 'quote (multiple-value-list (round first second)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1916 (princ " :one-fround-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1917 (princ (list 'quote (multiple-value-list (fround first)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1918 (princ " :two-fround-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1919 (princ (list 'quote (multiple-value-list (fround first second)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1920 (princ " :one-truncate-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1921 (princ (list 'quote (multiple-value-list (truncate first)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1922 (princ " :two-truncate-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1923 (princ (list 'quote (multiple-value-list (truncate first second)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1924 (princ " :one-ftruncate-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1925 (princ (list 'quote (multiple-value-list (ftruncate first)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1926 (princ " :two-ftruncate-result ") |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4608
diff
changeset
|
1927 (princ (list 'quote (multiple-value-list (ftruncate first second)))))) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1928 |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1929 ;; Multiple value tests. |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1930 |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1931 (flet ((foo (x y) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1932 (floor (+ x y) y)) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1933 (foo-zero (x y) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1934 (values (floor (+ x y) y))) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1935 (multiple-value-function-returning-t () |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1936 (values t pi e degrees-to-radians radians-to-degrees)) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1937 (multiple-value-function-returning-nil () |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4679
diff
changeset
|
1938 (values nil pi e radians-to-degrees degrees-to-radians)) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1939 (function-throwing-multiple-values () |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1940 (let* ((listing '(0 3 4 nil "string" symbol)) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1941 (tail listing) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1942 elt) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1943 (while t |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1944 (setq tail (cdr listing) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1945 elt (car listing) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1946 listing tail) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1947 (when (null elt) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1948 (throw 'VoN61Lo4Y (multiple-value-function-returning-t))))))) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1949 (Assert |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1950 (= (+ (floor 5 3) (floor 19 4)) (+ 1 4) 5) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1951 "Checking that multiple values are discarded correctly as func args") |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1952 (Assert |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1953 (= 2 (length (multiple-value-list (foo 400 (1+ most-positive-fixnum))))) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1954 "Checking multiple values are passed through correctly as return values") |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1955 (Assert |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1956 (= 1 (length (multiple-value-list |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1957 (foo-zero 400 (1+ most-positive-fixnum))))) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1958 "Checking multiple values are discarded correctly when forced") |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1959 (Check-Error setting-constant (setq multiple-values-limit 20)) |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
1960 (Assert-equal '(-1 1) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
1961 (multiple-value-list (floor -3 4)) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1962 "Checking #'multiple-value-list gives a sane result") |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1963 (let ((ey 40000) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1964 (bee "this is a string") |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1965 (cee #s(hash-table size 256 data (969 ?\xF9)))) |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
1966 (Assert-equal |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
1967 (multiple-value-list (values ey bee cee)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
1968 (multiple-value-list (values-list (list ey bee cee))) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1969 "Checking that #'values and #'values-list are correctly related") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
1970 (Assert-equal |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
1971 (multiple-value-list (values-list (list ey bee cee))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
1972 (multiple-value-list (apply #'values (list ey bee cee))) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1973 "Checking #'values-list and #'apply with #values are correctly related")) |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
1974 (Assert= (multiple-value-call #'+ (floor 5 3) (floor 19 4)) 10 |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1975 "Checking #'multiple-value-call gives reasonable results.") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
1976 (Assert= (multiple-value-call (values '+ '*) (floor 5 3) (floor 19 4)) 10 |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1977 "Checking #'multiple-value-call correct when first arg multiple.") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
1978 (Assert= 1 (length (multiple-value-list (prog1 (floor pi) "hi there"))) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1979 "Checking #'prog1 does not pass back multiple values") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
1980 (Assert= 2 (length (multiple-value-list |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
1981 (multiple-value-prog1 (floor pi) "hi there"))) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1982 "Checking #'multiple-value-prog1 passes back multiple values") |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1983 (multiple-value-bind (floored remainder this-is-nil) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1984 (floor pi 1.0) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1985 (Assert= floored 3 |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1986 "Checking floored bound correctly") |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1987 (Assert-eql remainder (- pi 3.0) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1988 "Checking remainder bound correctly") |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1989 (Assert (null this-is-nil) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1990 "Checking trailing arg bound but nil")) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1991 (let ((ey 40000) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1992 (bee "this is a string") |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1993 (cee #s(hash-table size 256 data (969 ?\xF9)))) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1994 (multiple-value-setq (ey bee cee) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1995 (ffloor e 1.0)) |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1996 (Assert-eql 2.0 ey "Checking ey set correctly") |
|
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
1997 (Assert-eql bee (- e 2.0) "Checking bee set correctly") |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
1998 (Assert (null cee) "Checking cee set to nil correctly")) |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
1999 (Assert= 3 (length (multiple-value-list (eval '(values nil t pi)))) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2000 "Checking #'eval passes back multiple values") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2001 (Assert= 2 (length (multiple-value-list (apply #'floor '(5 3)))) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2002 "Checking #'apply passes back multiple values") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2003 (Assert= 2 (length (multiple-value-list (funcall #'floor 5 3))) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2004 "Checking #'funcall passes back multiple values") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2005 (Assert-equal '(1 2) (multiple-value-list |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2006 (multiple-value-call #'floor (values 5 3))) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2007 "Checking #'multiple-value-call passes back multiple values correctly") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2008 (Assert= 1 (length (multiple-value-list |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2009 (and (multiple-value-function-returning-nil) t))) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2010 "Checking multiple values from non-trailing forms discarded by #'and") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2011 (Assert= 5 (length (multiple-value-list |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2012 (and t (multiple-value-function-returning-nil)))) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2013 "Checking multiple values from final forms not discarded by #'and") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2014 (Assert= 1 (length (multiple-value-list |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2015 (or (multiple-value-function-returning-t) t))) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2016 "Checking multiple values from non-trailing forms discarded by #'and") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2017 (Assert= 5 (length (multiple-value-list |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2018 (or nil (multiple-value-function-returning-t)))) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2019 "Checking multiple values from final forms not discarded by #'and") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2020 (Assert= 1 (length (multiple-value-list |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2021 (cond ((multiple-value-function-returning-t))))) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2022 "Checking cond doesn't pass back multiple values in tests.") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2023 (Assert-equal (list nil pi e radians-to-degrees degrees-to-radians) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2024 (multiple-value-list |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2025 (cond (t (multiple-value-function-returning-nil)))) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2026 "Checking cond passes back multiple values in clauses.") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2027 (Assert= 1 (length (multiple-value-list |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2028 (prog1 (multiple-value-function-returning-nil)))) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2029 "Checking prog1 discards multiple values correctly.") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2030 (Assert= 5 (length (multiple-value-list |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2031 (multiple-value-prog1 |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2032 (multiple-value-function-returning-nil)))) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2033 "Checking multiple-value-prog1 passes back multiple values correctly.") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2034 (Assert-equal (list t pi e degrees-to-radians radians-to-degrees) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2035 (multiple-value-list |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2036 (catch 'VoN61Lo4Y (function-throwing-multiple-values)))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2037 (Assert-equal (list t pi e degrees-to-radians radians-to-degrees) |
|
4679
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2038 (multiple-value-list |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2039 (loop |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2040 for eye in `(a b c d ,e f g ,nil ,pi) |
|
2c64d2bbb316
Test the multiple-value functionality.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4678
diff
changeset
|
2041 do (when (null eye) |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2042 (return (multiple-value-function-returning-t))))) |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4679
diff
changeset
|
2043 "Checking #'loop passes back multiple values correctly.") |
|
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4679
diff
changeset
|
2044 (Assert |
|
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4679
diff
changeset
|
2045 (null (or)) |
|
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4679
diff
changeset
|
2046 "Checking #'or behaves correctly with zero arguments.") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2047 (Assert-eq t (and) |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4679
diff
changeset
|
2048 "Checking #'and behaves correctly with zero arguments.") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2049 (Assert= (* 3.0 (- pi 3.0)) |
|
4742
4cf435fcebbc
Make #'letf not error if handed a #'values form.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4732
diff
changeset
|
2050 (letf (((values three one-four-one-five-nine) (floor pi))) |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2051 (* three one-four-one-five-nine)) |
|
4742
4cf435fcebbc
Make #'letf not error if handed a #'values form.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4732
diff
changeset
|
2052 "checking letf handles #'values in a basic sense")) |
|
4686
cdabd56ce1b5
Fix various small issues with the multiple-value implementation.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4679
diff
changeset
|
2053 |
|
4792
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2054 ;; #'equalp tests. |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2055 (let ((string-variable "aBcDeeFgH\u00Edj") |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2056 (eacute-character ?\u00E9) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2057 (Eacute-character ?\u00c9) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2058 (+base-chars+ (loop |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2059 with res = (make-string 96 ?\x20) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2060 for int-char from #x20 to #x7f |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2061 for char being each element in-ref res |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2062 do (setf char (int-to-char int-char)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2063 finally return res))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2064 (let ((equal-lists |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2065 '((111111111111111111111111111111111111111111111111111 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2066 111111111111111111111111111111111111111111111111111.0) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2067 (0 0.0 0.000 -0 -0.0 -0.000 #b0 0/5 -0/5) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2068 (21845 #b101010101010101 #x5555) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2069 (1.5 1.500000000000000000000000000000000000000000000000000000000 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2070 3/2) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2071 (-55 -110/2) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2072 ;; Can't use this, these values aren't `='. |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2073 ;;(-12345678901234567890123457890123457890123457890123457890123457890 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2074 ;; -12345678901234567890123457890123457890123457890123457890123457890.0) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2075 ))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2076 (loop for li in equal-lists do |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2077 (loop for (x . tail) on li do |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2078 (loop for y in tail do |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2079 (Assert-equalp x y) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2080 (Assert-equalp y x))))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2081 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2082 (let ((diff-list |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2083 `(0 1 2 3 1000 5000000000 5555555555555555555555555555555555555 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2084 -1 -2 -3 -1000 -5000000000 -5555555555555555555555555555555555555 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2085 1/2 1/3 2/3 8/2 355/113 (/ 3/2 0.2) (/ 3/2 0.7) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2086 55555555555555555555555555555555555555555/2718281828459045 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2087 0.111111111111111111111111111111111111111111111111111111111111111 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2088 1e+300 1e+301 -1e+300 -1e+301))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2089 (loop for (x . tail) on diff-list do |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2090 (loop for y in tail do |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2091 (Assert-not-equalp x y) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2092 (Assert-not-equalp y x)))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2093 |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
2094 (Assert-equalp "hi there" "Hi There" |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2095 "checking equalp isn't case-sensitive") |
|
4855
189fb67ca31a
Create Assert-eq, Assert-equal, etc.
Ben Wing <ben@xemacs.org>
parents:
4795
diff
changeset
|
2096 (Assert-equalp 99 99.0 |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2097 "checking equalp compares numerical values of different types") |
|
4792
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2098 (Assert (null (equalp 99 ?c)) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2099 "checking equalp does not convert characters to numbers") |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2100 ;; Fixed in Hg d0ea57eb3de4. |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2101 (Assert (null (equalp "hi there" [hi there])) |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2102 "checking equalp doesn't error with string and non-string") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2103 (Assert-equalp "ABCDEEFGH\u00CDJ" string-variable |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2104 "checking #'equalp is case-insensitive with an upcased constant") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2105 (Assert-equalp "abcdeefgh\xedj" string-variable |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2106 "checking #'equalp is case-insensitive with a downcased constant") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2107 (Assert-equalp string-variable string-variable |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2108 "checking #'equalp works when handed the same string twice") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2109 (Assert-equalp string-variable "aBcDeeFgH\u00Edj" |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2110 "check #'equalp is case-insensitive with a variable-cased constant") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2111 (Assert-equalp "" (bit-vector) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2112 "check empty string and empty bit-vector are #'equalp.") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2113 (Assert-equalp (string) (bit-vector) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2114 "check empty string and empty bit-vector are #'equalp, no constants") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2115 (Assert-equalp "hi there" (vector ?h ?i ?\ ?t ?h ?e ?r ?e) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2116 "check string and vector with same contents #'equalp") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2117 (Assert-equalp (string ?h ?i ?\ ?t ?h ?e ?r ?e) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2118 (vector ?h ?i ?\ ?t ?h ?e ?r ?e) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2119 "check string and vector with same contents #'equalp, no constants") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2120 (Assert-equalp [?h ?i ?\ ?t ?h ?e ?r ?e] |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2121 (string ?h ?i ?\ ?t ?h ?e ?r ?e) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2122 "check string and vector with same contents #'equalp, vector constant") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2123 (Assert-equalp [0 1.0 0.0 0 1] |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2124 (bit-vector 0 1 0 0 1) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2125 "check vector and bit-vector with same contents #'equalp,\ |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2126 vector constant") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2127 (Assert-not-equalp [0 2 0.0 0 1] |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2128 (bit-vector 0 1 0 0 1) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2129 "check vector and bit-vector with different contents not #'equalp,\ |
|
4792
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2130 vector constant") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2131 (Assert-equalp #*01001 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2132 (vector 0 1.0 0.0 0 1) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2133 "check vector and bit-vector with same contents #'equalp,\ |
|
4792
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2134 bit-vector constant") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2135 (Assert-equalp ?\u00E9 Eacute-character |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2136 "checking characters are case-insensitive, one constant") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2137 (Assert-not-equalp ?\u00E9 (aref (format "%c" ?a) 0) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2138 "checking distinct characters are not equalp, one constant") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2139 (Assert-equalp t (and) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2140 "checking symbols are correctly #'equalp") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2141 (Assert-not-equalp t (or nil '#:t) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2142 "checking distinct symbols with the same name are not #'equalp") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2143 (Assert-equalp #s(char-table type generic data (?\u0080 "hi-there")) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2144 (let ((aragh (make-char-table 'generic))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2145 (put-char-table ?\u0080 "hi-there" aragh) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2146 aragh) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2147 "checking #'equalp succeeds correctly, char-tables") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2148 (Assert-equalp #s(char-table type generic data (?\u0080 "hi-there")) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2149 (let ((aragh (make-char-table 'generic))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2150 (put-char-table ?\u0080 "HI-THERE" aragh) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2151 aragh) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2152 "checking #'equalp succeeds correctly, char-tables") |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2153 (Assert-not-equalp #s(char-table type generic data (?\u0080 "hi-there")) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2154 (let ((aragh (make-char-table 'generic))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2155 (put-char-table ?\u0080 "hi there" aragh) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2156 aragh) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2157 "checking #'equalp fails correctly, char-tables")) |
|
4792
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2158 |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2159 ;; There are more tests available for equalp here: |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2160 ;; |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2161 ;; http://www.parhasard.net/xemacs/equalp-tests.el |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2162 ;; |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2163 ;; They are taken from Paul Dietz' GCL ANSI test suite, licensed under the |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2164 ;; LGPL and part of GNU Common Lisp; the GCL people didn't respond to |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2165 ;; several requests for information on who owned the copyright for the |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2166 ;; files, so I haven't included the tests with XEmacs. Anyone doing XEmacs |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2167 ;; development on equalp should still run them, though. Aidan Kehoe, Thu Dec |
|
95b04754ea8c
Make #'equalp more compatible with CL; add a compiler macro, test & doc it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4742
diff
changeset
|
2168 ;; 31 14:53:52 GMT 2009. |
|
4732
2491a837112c
Fix typo in test of equalp and add more tests.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4728
diff
changeset
|
2169 |
|
4795
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2170 (loop |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2171 for special-form in '(multiple-value-call setq-default quote throw |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2172 save-current-buffer and or) |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2173 with not-special-form = nil |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2174 do |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2175 (Assert (special-form-p special-form) |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2176 (format "checking %S is a special operator" special-form)) |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2177 (setq not-special-form |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2178 (intern (format "%s-gMAu" (symbol-name special-form)))) |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2179 (Assert (not (special-form-p not-special-form)) |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2180 (format "checking %S is a special operator" special-form)) |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2181 (Assert (not (functionp special-form)) |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2182 (format "checking %S is not a function" special-form))) |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2183 |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2184 (loop |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2185 for real-function in '(find-file quote-maybe + - find-file-read-only) |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2186 do (Assert (functionp real-function) |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2187 (format "checking %S is a function" real-function))) |
|
084056f46755
#'functionp gives nil for special forms, as in CL and GNU Emacs 23.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4792
diff
changeset
|
2188 |
|
4885
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2189 ;; #'member, #'assoc tests. |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2190 |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2191 (when (featurep 'bignum) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2192 (let* ((member*-list `(0 9 342 [hi there] ,(1+ most-positive-fixnum) 0 |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2193 0.0 ,(1- most-negative-fixnum) nil)) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2194 (assoc*-list (loop |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2195 for elt in member*-list |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2196 collect (cons elt (random)))) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2197 (hashing (make-hash-table :test 'eql)) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2198 hashed-bignum) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2199 (macrolet |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2200 ((1+most-positive-fixnum () |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2201 (1+ most-positive-fixnum)) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2202 (1-most-negative-fixnum () |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2203 (1- most-negative-fixnum)) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2204 (*-2-most-positive-fixnum () |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2205 (* 2 most-positive-fixnum))) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2206 (Assert-eq |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2207 (member* (1+ most-positive-fixnum) member*-list) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2208 (member* (1+ most-positive-fixnum) member*-list :test #'eql) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2209 "checking #'member* correct if #'eql not explicitly specified") |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2210 (Assert-eq |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2211 (assoc* (1+ most-positive-fixnum) assoc*-list) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2212 (assoc* (1+ most-positive-fixnum) assoc*-list :test #'eql) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2213 "checking #'assoc* correct if #'eql not explicitly specified") |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2214 (Assert-eq |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2215 (rassoc* (1- most-negative-fixnum) assoc*-list) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2216 (rassoc* (1- most-negative-fixnum) assoc*-list :test #'eql) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2217 "checking #'rassoc* correct if #'eql not explicitly specified") |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2218 (Assert-eql (1+most-positive-fixnum) (1+ most-positive-fixnum) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4897
diff
changeset
|
2219 "checking #'eql handles a bignum literal properly.") |
|
4885
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2220 (Assert-eq |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2221 (member* (1+most-positive-fixnum) member*-list) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2222 (member* (1+ most-positive-fixnum) member*-list :test #'equal) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2223 "checking #'member* compiler macro correct with literal bignum") |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2224 (Assert-eq |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2225 (assoc* (1+most-positive-fixnum) assoc*-list) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2226 (assoc* (1+ most-positive-fixnum) assoc*-list :test #'equal) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2227 "checking #'assoc* compiler macro correct with literal bignum") |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2228 (puthash (setq hashed-bignum (*-2-most-positive-fixnum)) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2229 (gensym) hashing) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2230 (Assert-eq |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2231 (gethash (* 2 most-positive-fixnum) hashing) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2232 (gethash hashed-bignum hashing) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2233 "checking hashing works correctly with #'eql tests and bignums")))) |
|
6772ce4d982b
Fix hash tables, #'member*, #'assoc*, #'eql compiler macros if bignums
Aidan Kehoe <kehoea@parhasard.net>
parents:
4855
diff
changeset
|
2234 |
|
4732
2491a837112c
Fix typo in test of equalp and add more tests.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4728
diff
changeset
|
2235 ;;; end of lisp-tests.el |