Mercurial > hg > xemacs-beta
annotate lisp/cl-extra.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 | c17c857e20bf |
| rev | line source |
|---|---|
| 613 | 1 ;;; cl-extra.el --- Common Lisp extensions for XEmacs Lisp (part two) |
| 428 | 2 |
| 2153 | 3 ;; Copyright (C) 1993,2000,2003 Free Software Foundation, Inc. |
| 801 | 4 ;; Copyright (C) 2002 Ben Wing. |
| 428 | 5 |
| 6 ;; Author: Dave Gillespie <daveg@synaptics.com> | |
| 7 ;; Maintainer: XEmacs Development Team | |
| 8 ;; Version: 2.02 | |
| 9 ;; Keywords: extensions, dumped | |
| 10 | |
| 11 ;; This file is part of XEmacs. | |
| 12 | |
| 13 ;; XEmacs is free software; you can redistribute it and/or modify it | |
| 14 ;; under the terms of the GNU General Public License as published by | |
| 15 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 16 ;; any later version. | |
| 17 | |
| 18 ;; XEmacs is distributed in the hope that it will be useful, but | |
| 19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
| 21 ;; General Public License for more details. | |
| 22 | |
| 23 ;; You should have received a copy of the GNU General Public License | |
| 24 ;; along with XEmacs; see the file COPYING. If not, write to the Free | |
| 25 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA | |
| 26 ;; 02111-1307, USA. | |
| 27 | |
| 2153 | 28 ;;; Synched up with: FSF 21.3. |
| 428 | 29 |
| 30 ;;; Commentary: | |
| 31 | |
| 32 ;; This file is dumped with XEmacs. | |
| 33 | |
| 34 ;; These are extensions to Emacs Lisp that provide a degree of | |
| 35 ;; Common Lisp compatibility, beyond what is already built-in | |
| 36 ;; in Emacs Lisp. | |
| 37 ;; | |
| 38 ;; This package was written by Dave Gillespie; it is a complete | |
| 39 ;; rewrite of Cesar Quiroz's original cl.el package of December 1986. | |
| 40 ;; | |
| 41 ;; Bug reports, comments, and suggestions are welcome! | |
| 42 | |
| 43 ;; This file contains portions of the Common Lisp extensions | |
| 44 ;; package which are autoloaded since they are relatively obscure. | |
| 45 | |
| 46 ;; See cl.el for Change Log. | |
| 47 | |
| 48 | |
| 49 ;;; Code: | |
| 2153 | 50 ;; XEmacs addition |
| 428 | 51 (eval-when-compile |
| 52 (require 'obsolete)) | |
| 53 | |
| 54 (or (memq 'cl-19 features) | |
| 55 (error "Tried to load `cl-extra' before `cl'!")) | |
| 56 | |
| 57 | |
| 58 ;;; Type coercion. | |
| 59 | |
| 60 (defun coerce (x type) | |
| 61 "Coerce OBJECT to type TYPE. | |
| 62 TYPE is a Common Lisp type specifier." | |
| 63 (cond ((eq type 'list) (if (listp x) x (append x nil))) | |
| 64 ((eq type 'vector) (if (vectorp x) x (vconcat x))) | |
| 65 ((eq type 'string) (if (stringp x) x (concat x))) | |
| 66 ((eq type 'array) (if (arrayp x) x (vconcat x))) | |
| 67 ((and (eq type 'character) (stringp x) (= (length x) 1)) (aref x 0)) | |
| 68 ((and (eq type 'character) (symbolp x)) (coerce (symbol-name x) type)) | |
| 2153 | 69 ;; XEmacs addition character <-> integer coercions |
| 446 | 70 ((and (eq type 'character) (char-int-p x)) (int-char x)) |
| 71 ((and (eq type 'integer) (characterp x)) (char-int x)) | |
| 428 | 72 ((eq type 'float) (float x)) |
| 2153 | 73 ;; XEmacs addition: enhanced numeric type coercions |
| 2367 | 74 ((and-fboundp 'coerce-number |
| 75 (memq type '(integer ratio bigfloat)) | |
| 76 (coerce-number x type))) | |
| 2153 | 77 ;; XEmacs addition: bit-vector coercion |
| 428 | 78 ((eq type 'bit-vector) (if (bit-vector-p x) x |
| 79 (apply 'bit-vector (append x nil)))) | |
| 2153 | 80 ;; XEmacs addition: weak-list coercion |
| 428 | 81 ((eq type 'weak-list) |
| 82 (if (weak-list-p x) x | |
| 83 (let ((wl (make-weak-list))) | |
| 84 (set-weak-list-list wl (if (listp x) x (append x nil))) | |
| 85 wl))) | |
| 86 ((typep x type) x) | |
| 87 (t (error "Can't coerce %s to type %s" x type)))) | |
| 88 | |
| 89 | |
|
4906
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
90 ;;;;; Predicates. |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
91 ;; |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
92 ;;;; I'd actually prefer not to have this inline, the space |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
93 ;;;; vs. amount-it's-called trade-off isn't reasonable, but that would |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
94 ;;;; introduce bytecode problems with the compiler macro in cl-macs.el. |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
95 ;;(defsubst cl-string-vector-equalp (cl-string cl-vector) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
96 ;; "Helper function for `equalp', which see." |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
97 ;;; (check-argument-type #'stringp cl-string) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
98 ;;; (check-argument-type #'vector cl-vector) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
99 ;; (let ((cl-i (length cl-string)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
100 ;; cl-char cl-other) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
101 ;; (when (= cl-i (length cl-vector)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
102 ;; (while (and (>= (setq cl-i (1- cl-i)) 0) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
103 ;; (or (eq (setq cl-char (aref cl-string cl-i)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
104 ;; (setq cl-other (aref cl-vector cl-i))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
105 ;; (and (characterp cl-other) ; Note we want to call this |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
106 ;; ; as rarely as possible, it |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
107 ;; ; doesn't have a bytecode. |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
108 ;; (eq (downcase cl-char) (downcase cl-other)))))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
109 ;; (< cl-i 0)))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
110 ;; |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
111 ;;;; See comment on cl-string-vector-equalp above. |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
112 ;;(defsubst cl-bit-vector-vector-equalp (cl-bit-vector cl-vector) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
113 ;; "Helper function for `equalp', which see." |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
114 ;;; (check-argument-type #'bit-vector-p cl-bit-vector) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
115 ;;; (check-argument-type #'vectorp cl-vector) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
116 ;; (let ((cl-i (length cl-bit-vector)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
117 ;; cl-other) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
118 ;; (when (= cl-i (length cl-vector)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
119 ;; (while (and (>= (setq cl-i (1- cl-i)) 0) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
120 ;; (numberp (setq cl-other (aref cl-vector cl-i))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
121 ;; ;; Differs from clisp here. |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
122 ;; (= (aref cl-bit-vector cl-i) cl-other))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
123 ;; (< cl-i 0)))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
124 ;; |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
125 ;;;; These two helper functions call equalp recursively, the two above have no |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
126 ;;;; need to. |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
127 ;;(defsubst cl-vector-array-equalp (cl-vector cl-array) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
128 ;; "Helper function for `equalp', which see." |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
129 ;;; (check-argument-type #'vector cl-vector) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
130 ;;; (check-argument-type #'arrayp cl-array) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
131 ;; (let ((cl-i (length cl-vector))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
132 ;; (when (= cl-i (length cl-array)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
133 ;; (while (and (>= (setq cl-i (1- cl-i)) 0) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
134 ;; (equalp (aref cl-vector cl-i) (aref cl-array cl-i)))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
135 ;; (< cl-i 0)))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
136 ;; |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
137 ;;(defsubst cl-hash-table-contents-equalp (cl-hash-table-1 cl-hash-table-2) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
138 ;; "Helper function for `equalp', which see." |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
139 ;; (symbol-macrolet |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
140 ;; ;; If someone has gone and fished the uninterned symbol out of this |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
141 ;; ;; function's constants vector, and subsequently stored it as a value |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
142 ;; ;; in a hash table, it's their own damn fault when |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
143 ;; ;; `cl-hash-table-contents-equalp' gives the wrong answer. |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
144 ;; ((equalp-default '#:equalp-default)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
145 ;; (loop |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
146 ;; for x-key being the hash-key in cl-hash-table-1 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
147 ;; using (hash-value x-value) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
148 ;; with y-value = nil |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
149 ;; always (and (not (eq equalp-default |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
150 ;; (setq y-value (gethash x-key cl-hash-table-2 |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
151 ;; equalp-default)))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
152 ;; (equalp y-value x-value))))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
153 ;; |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
154 ;;(defun equalp (x y) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
155 ;; "Return t if two Lisp objects have similar structures and contents. |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
156 ;; |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
157 ;;This is like `equal', except that it accepts numerically equal |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
158 ;;numbers of different types (float, integer, bignum, bigfloat), and also |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
159 ;;compares strings and characters case-insensitively. |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
160 ;; |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
161 ;;Arrays (that is, strings, bit-vectors, and vectors) of the same length and |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
162 ;;with contents that are `equalp' are themselves `equalp'. |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
163 ;; |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
164 ;;Two hash tables are `equalp' if they have the same test (see |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
165 ;;`hash-table-test'), if they have the same number of entries, and if, for |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
166 ;;each entry in one hash table, its key is equivalent to a key in the other |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
167 ;;hash table using the hash table test, and its value is `equalp' to the other |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
168 ;;hash table's value for that key." |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
169 ;; (cond ((eq x y)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
170 ;; ((stringp x) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
171 ;; (if (stringp y) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
172 ;; (eq t (compare-strings x nil nil y nil nil t)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
173 ;; (if (vectorp y) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
174 ;; (cl-string-vector-equalp x y) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
175 ;; ;; bit-vectors and strings are only equalp if they're |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
176 ;; ;; zero-length: |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
177 ;; (and (equal "" x) (equal #* y))))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
178 ;; ((numberp x) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
179 ;; (and (numberp y) (= x y))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
180 ;; ((consp x) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
181 ;; (while (and (consp x) (consp y) (equalp (car x) (car y))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
182 ;; (setq x (cdr x) y (cdr y))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
183 ;; (and (not (consp x)) (equalp x y))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
184 ;; (t |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
185 ;; ;; From here on, the type tests don't (yet) have bytecodes. |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
186 ;; (let ((x-type (type-of x))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
187 ;; (cond ((eq 'vector x-type) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
188 ;; (if (stringp y) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
189 ;; (cl-string-vector-equalp y x) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
190 ;; (if (vectorp y) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
191 ;; (cl-vector-array-equalp x y) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
192 ;; (if (bit-vector-p y) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
193 ;; (cl-bit-vector-vector-equalp y x))))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
194 ;; ((eq 'character x-type) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
195 ;; (and (characterp y) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
196 ;; ;; If the characters are actually identical, the |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
197 ;; ;; first eq test will have caught them above; we only |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
198 ;; ;; need to check them case-insensitively here. |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
199 ;; (eq (downcase x) (downcase y)))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
200 ;; ((eq 'hash-table x-type) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
201 ;; (and (hash-table-p y) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
202 ;; (eq (hash-table-test x) (hash-table-test y)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
203 ;; (= (hash-table-count x) (hash-table-count y)) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
204 ;; (cl-hash-table-contents-equalp x y))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
205 ;; ((eq 'bit-vector x-type) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
206 ;; (if (bit-vector-p y) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
207 ;; (equal x y) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
208 ;; (if (vectorp y) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
209 ;; (cl-bit-vector-vector-equalp x y) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
210 ;; ;; bit-vectors and strings are only equalp if they're |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
211 ;; ;; zero-length: |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
212 ;; (and (equal "" y) (equal #* x))))) |
|
6ef8256a020a
implement equalp in C, fix case-folding, add equal() method for keymaps
Ben Wing <ben@xemacs.org>
parents:
4800
diff
changeset
|
213 ;; (t (equal x y))))))) |
| 428 | 214 |
| 215 ;;; Control structures. | |
| 216 | |
| 217 (defun cl-mapcar-many (cl-func cl-seqs) | |
| 218 (if (cdr (cdr cl-seqs)) | |
| 219 (let* ((cl-res nil) | |
| 220 (cl-n (apply 'min (mapcar 'length cl-seqs))) | |
| 221 (cl-i 0) | |
| 222 (cl-args (copy-sequence cl-seqs)) | |
| 223 cl-p1 cl-p2) | |
| 224 (setq cl-seqs (copy-sequence cl-seqs)) | |
| 225 (while (< cl-i cl-n) | |
| 226 (setq cl-p1 cl-seqs cl-p2 cl-args) | |
| 227 (while cl-p1 | |
| 228 (setcar cl-p2 | |
| 229 (if (consp (car cl-p1)) | |
| 230 (prog1 (car (car cl-p1)) | |
| 231 (setcar cl-p1 (cdr (car cl-p1)))) | |
| 232 (aref (car cl-p1) cl-i))) | |
| 233 (setq cl-p1 (cdr cl-p1) cl-p2 (cdr cl-p2))) | |
| 2153 | 234 (push (apply cl-func cl-args) cl-res) |
| 428 | 235 (setq cl-i (1+ cl-i))) |
| 236 (nreverse cl-res)) | |
| 237 (let ((cl-res nil) | |
| 238 (cl-x (car cl-seqs)) | |
| 239 (cl-y (nth 1 cl-seqs))) | |
| 240 (let ((cl-n (min (length cl-x) (length cl-y))) | |
| 241 (cl-i -1)) | |
| 242 (while (< (setq cl-i (1+ cl-i)) cl-n) | |
| 2153 | 243 (push (funcall cl-func |
| 244 (if (consp cl-x) (pop cl-x) (aref cl-x cl-i)) | |
| 245 (if (consp cl-y) (pop cl-y) (aref cl-y cl-i))) | |
| 428 | 246 cl-res))) |
| 247 (nreverse cl-res)))) | |
| 248 | |
| 249 (defun map (cl-type cl-func cl-seq &rest cl-rest) | |
| 250 "Map a function across one or more sequences, returning a sequence. | |
| 251 TYPE is the sequence type to return, FUNC is the function, and SEQS | |
| 252 are the argument sequences." | |
| 253 (let ((cl-res (apply 'mapcar* cl-func cl-seq cl-rest))) | |
| 254 (and cl-type (coerce cl-res cl-type)))) | |
| 255 | |
| 256 (defun maplist (cl-func cl-list &rest cl-rest) | |
| 257 "Map FUNC to each sublist of LIST or LISTS. | |
| 258 Like `mapcar', except applies to lists and their cdr's rather than to | |
| 259 the elements themselves." | |
| 260 (if cl-rest | |
| 261 (let ((cl-res nil) | |
| 262 (cl-args (cons cl-list (copy-sequence cl-rest))) | |
| 263 cl-p) | |
| 264 (while (not (memq nil cl-args)) | |
| 2153 | 265 (push (apply cl-func cl-args) cl-res) |
| 428 | 266 (setq cl-p cl-args) |
| 2153 | 267 (while cl-p (setcar cl-p (cdr (pop cl-p)) ))) |
| 428 | 268 (nreverse cl-res)) |
| 269 (let ((cl-res nil)) | |
| 270 (while cl-list | |
| 2153 | 271 (push (funcall cl-func cl-list) cl-res) |
| 428 | 272 (setq cl-list (cdr cl-list))) |
| 273 (nreverse cl-res)))) | |
| 274 | |
| 2153 | 275 ;; XEmacs change: in Emacs, this function is named cl-mapc. |
| 428 | 276 (defun mapc (cl-func cl-seq &rest cl-rest) |
| 277 "Like `mapcar', but does not accumulate values returned by the function." | |
| 278 (if cl-rest | |
| 279 (apply 'map nil cl-func cl-seq cl-rest) | |
| 280 ;; XEmacs change: in the simplest case we call mapc-internal, | |
| 281 ;; which really doesn't accumulate any results. | |
| 282 (mapc-internal cl-func cl-seq)) | |
| 283 cl-seq) | |
| 284 | |
| 2153 | 285 ;; XEmacs addition: FSF compatibility |
| 286 (defalias 'cl-mapc 'mapc) | |
| 287 | |
| 428 | 288 (defun mapl (cl-func cl-list &rest cl-rest) |
| 289 "Like `maplist', but does not accumulate values returned by the function." | |
| 290 (if cl-rest | |
| 291 (apply 'maplist cl-func cl-list cl-rest) | |
| 292 (let ((cl-p cl-list)) | |
| 293 (while cl-p (funcall cl-func cl-p) (setq cl-p (cdr cl-p))))) | |
| 294 cl-list) | |
| 295 | |
| 296 (defun mapcan (cl-func cl-seq &rest cl-rest) | |
| 297 "Like `mapcar', but nconc's together the values returned by the function." | |
| 298 (apply 'nconc (apply 'mapcar* cl-func cl-seq cl-rest))) | |
| 299 | |
| 300 (defun mapcon (cl-func cl-list &rest cl-rest) | |
| 301 "Like `maplist', but nconc's together the values returned by the function." | |
| 302 (apply 'nconc (apply 'maplist cl-func cl-list cl-rest))) | |
| 303 | |
| 304 (defun some (cl-pred cl-seq &rest cl-rest) | |
| 305 "Return true if PREDICATE is true of any element of SEQ or SEQs. | |
| 306 If so, return the true (non-nil) value returned by PREDICATE." | |
| 307 (if (or cl-rest (nlistp cl-seq)) | |
| 308 (catch 'cl-some | |
| 309 (apply 'map nil | |
| 310 (function (lambda (&rest cl-x) | |
| 311 (let ((cl-res (apply cl-pred cl-x))) | |
| 312 (if cl-res (throw 'cl-some cl-res))))) | |
| 313 cl-seq cl-rest) nil) | |
| 314 (let ((cl-x nil)) | |
| 2153 | 315 (while (and cl-seq (not (setq cl-x (funcall cl-pred (pop cl-seq)))))) |
| 428 | 316 cl-x))) |
| 317 | |
| 318 (defun every (cl-pred cl-seq &rest cl-rest) | |
| 319 "Return true if PREDICATE is true of every element of SEQ or SEQs." | |
| 320 (if (or cl-rest (nlistp cl-seq)) | |
| 321 (catch 'cl-every | |
| 322 (apply 'map nil | |
| 323 (function (lambda (&rest cl-x) | |
| 324 (or (apply cl-pred cl-x) (throw 'cl-every nil)))) | |
| 325 cl-seq cl-rest) t) | |
| 326 (while (and cl-seq (funcall cl-pred (car cl-seq))) | |
| 327 (setq cl-seq (cdr cl-seq))) | |
| 328 (null cl-seq))) | |
| 329 | |
| 330 (defun notany (cl-pred cl-seq &rest cl-rest) | |
| 331 "Return true if PREDICATE is false of every element of SEQ or SEQs." | |
| 332 (not (apply 'some cl-pred cl-seq cl-rest))) | |
| 333 | |
| 334 (defun notevery (cl-pred cl-seq &rest cl-rest) | |
| 335 "Return true if PREDICATE is false of some element of SEQ or SEQs." | |
| 336 (not (apply 'every cl-pred cl-seq cl-rest))) | |
| 337 | |
| 338 ;;; Support for `loop'. | |
| 2153 | 339 (defalias 'cl-map-keymap 'map-keymap) |
| 428 | 340 |
| 341 (defun cl-map-keymap-recursively (cl-func-rec cl-map &optional cl-base) | |
| 342 (or cl-base | |
| 2153 | 343 (setq cl-base (copy-sequence [0]))) |
| 344 (map-keymap | |
| 428 | 345 (function |
| 346 (lambda (cl-key cl-bind) | |
| 347 (aset cl-base (1- (length cl-base)) cl-key) | |
| 348 (if (keymapp cl-bind) | |
| 349 (cl-map-keymap-recursively | |
| 350 cl-func-rec cl-bind | |
| 2153 | 351 (vconcat cl-base (list 0))) |
| 428 | 352 (funcall cl-func-rec cl-base cl-bind)))) |
| 353 cl-map)) | |
| 354 | |
| 355 (defun cl-map-intervals (cl-func &optional cl-what cl-prop cl-start cl-end) | |
| 356 (or cl-what (setq cl-what (current-buffer))) | |
| 357 (if (bufferp cl-what) | |
| 358 (let (cl-mark cl-mark2 (cl-next t) cl-next2) | |
| 2153 | 359 (with-current-buffer cl-what |
| 428 | 360 (setq cl-mark (copy-marker (or cl-start (point-min)))) |
| 361 (setq cl-mark2 (and cl-end (copy-marker cl-end)))) | |
| 362 (while (and cl-next (or (not cl-mark2) (< cl-mark cl-mark2))) | |
| 2153 | 363 (setq cl-next (if cl-prop (next-single-property-change |
| 364 cl-mark cl-prop cl-what) | |
| 365 (next-property-change cl-mark cl-what)) | |
| 366 cl-next2 (or cl-next (with-current-buffer cl-what | |
| 367 (point-max)))) | |
| 428 | 368 (funcall cl-func (prog1 (marker-position cl-mark) |
| 369 (set-marker cl-mark cl-next2)) | |
| 370 (if cl-mark2 (min cl-next2 cl-mark2) cl-next2))) | |
| 371 (set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil))) | |
| 372 (or cl-start (setq cl-start 0)) | |
| 373 (or cl-end (setq cl-end (length cl-what))) | |
| 374 (while (< cl-start cl-end) | |
| 2153 | 375 (let ((cl-next (or (if cl-prop (next-single-property-change |
| 376 cl-start cl-prop cl-what) | |
| 377 (next-property-change cl-start cl-what)) | |
| 428 | 378 cl-end))) |
| 379 (funcall cl-func cl-start (min cl-next cl-end)) | |
| 380 (setq cl-start cl-next))))) | |
| 381 | |
| 382 (defun cl-map-overlays (cl-func &optional cl-buffer cl-start cl-end cl-arg) | |
| 383 (or cl-buffer (setq cl-buffer (current-buffer))) | |
| 502 | 384 (with-fboundp '(overlay-start overlay-end overlays-at next-overlay-change) |
| 385 (if-fboundp 'overlay-lists | |
| 428 | 386 |
| 502 | 387 ;; This is the preferred algorithm, though overlay-lists is |
| 388 ;; undocumented. | |
| 389 (let (cl-ovl) | |
| 2153 | 390 (with-current-buffer cl-buffer |
| 502 | 391 (setq cl-ovl (overlay-lists)) |
| 392 (if cl-start (setq cl-start (copy-marker cl-start))) | |
| 393 (if cl-end (setq cl-end (copy-marker cl-end)))) | |
| 394 (setq cl-ovl (nconc (car cl-ovl) (cdr cl-ovl))) | |
| 395 (while (and cl-ovl | |
| 396 (or (not (overlay-start (car cl-ovl))) | |
| 397 (and cl-end (>= (overlay-start (car cl-ovl)) cl-end)) | |
| 398 (and cl-start (<= (overlay-end (car cl-ovl)) | |
| 399 cl-start)) | |
| 400 (not (funcall cl-func (car cl-ovl) cl-arg)))) | |
| 401 (setq cl-ovl (cdr cl-ovl))) | |
| 402 (if cl-start (set-marker cl-start nil)) | |
| 403 (if cl-end (set-marker cl-end nil))) | |
| 404 | |
| 405 ;; This alternate algorithm fails to find zero-length overlays. | |
| 2153 | 406 (let ((cl-mark (with-current-buffer cl-buffer |
| 407 (copy-marker (or cl-start (point-min))))) | |
| 408 (cl-mark2 (and cl-end (with-current-buffer cl-buffer | |
| 409 (copy-marker cl-end)))) | |
| 502 | 410 cl-pos cl-ovl) |
| 411 (while (save-excursion | |
| 412 (and (setq cl-pos (marker-position cl-mark)) | |
| 413 (< cl-pos (or cl-mark2 (point-max))) | |
| 414 (progn | |
| 415 (set-buffer cl-buffer) | |
| 416 (setq cl-ovl (overlays-at cl-pos)) | |
| 417 (set-marker cl-mark (next-overlay-change cl-pos))))) | |
| 418 (while (and cl-ovl | |
| 419 (or (/= (overlay-start (car cl-ovl)) cl-pos) | |
| 420 (not (and (funcall cl-func (car cl-ovl) cl-arg) | |
| 421 (set-marker cl-mark nil))))) | |
| 422 (setq cl-ovl (cdr cl-ovl)))) | |
| 423 (set-marker cl-mark nil) (if cl-mark2 (set-marker cl-mark2 nil)))))) | |
| 428 | 424 |
| 425 ;;; Support for `setf'. | |
| 426 (defun cl-set-frame-visible-p (frame val) | |
| 427 (cond ((null val) (make-frame-invisible frame)) | |
| 428 ((eq val 'icon) (iconify-frame frame)) | |
| 429 (t (make-frame-visible frame))) | |
| 430 val) | |
| 431 | |
| 432 ;;; Support for `progv'. | |
| 433 (defvar cl-progv-save) | |
| 434 (defun cl-progv-before (syms values) | |
| 435 (while syms | |
| 2153 | 436 (push (if (boundp (car syms)) |
| 428 | 437 (cons (car syms) (symbol-value (car syms))) |
| 438 (car syms)) cl-progv-save) | |
| 439 (if values | |
| 2153 | 440 (set (pop syms) (pop values)) |
| 441 (makunbound (pop syms))))) | |
| 428 | 442 |
| 443 (defun cl-progv-after () | |
| 444 (while cl-progv-save | |
| 445 (if (consp (car cl-progv-save)) | |
| 446 (set (car (car cl-progv-save)) (cdr (car cl-progv-save))) | |
| 447 (makunbound (car cl-progv-save))) | |
| 2153 | 448 (pop cl-progv-save))) |
| 428 | 449 |
| 450 | |
| 451 ;;; Numbers. | |
| 452 | |
| 453 (defun gcd (&rest args) | |
| 454 "Return the greatest common divisor of the arguments." | |
| 2153 | 455 (let ((a (abs (or (pop args) 0)))) |
| 428 | 456 (while args |
| 2153 | 457 (let ((b (abs (pop args)))) |
| 428 | 458 (while (> b 0) (setq b (% a (setq a b)))))) |
| 459 a)) | |
| 460 | |
| 461 (defun lcm (&rest args) | |
| 462 "Return the least common multiple of the arguments." | |
| 463 (if (memq 0 args) | |
| 464 0 | |
| 2153 | 465 (let ((a (abs (or (pop args) 1)))) |
| 428 | 466 (while args |
| 2153 | 467 (let ((b (abs (pop args)))) |
| 428 | 468 (setq a (* (/ a (gcd a b)) b)))) |
| 469 a))) | |
| 470 | |
| 471 (defun isqrt (a) | |
| 472 "Return the integer square root of the argument." | |
| 473 (if (and (integerp a) (> a 0)) | |
| 474 ;; XEmacs change | |
| 475 (let ((g (cond ((>= a 1000000) 10000) ((>= a 10000) 1000) | |
| 476 ((>= a 100) 100) (t 10))) | |
| 477 g2) | |
| 478 (while (< (setq g2 (/ (+ g (/ a g)) 2)) g) | |
| 479 (setq g g2)) | |
| 480 g) | |
| 481 (if (eq a 0) 0 (signal 'arith-error nil)))) | |
| 482 | |
| 2153 | 483 ;; XEmacs addition |
| 428 | 484 (defun cl-expt (x y) |
| 485 "Return X raised to the power of Y. Works only for integer arguments." | |
| 486 (if (<= y 0) (if (= y 0) 1 (if (memq x '(-1 1)) (cl-expt x (- y)) 0)) | |
| 487 (* (if (= (% y 2) 0) 1 x) (cl-expt (* x x) (/ y 2))))) | |
| 488 (or (and (fboundp 'expt) (subrp (symbol-function 'expt))) | |
| 489 (defalias 'expt 'cl-expt)) | |
| 490 | |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
491 ;; We can't use macrolet in this file; whence the literal macro |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
492 ;; definition-and-call: |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
493 ((macro . (lambda (&rest symbols) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
494 "Make some old CL package truncate and round functions available. |
| 428 | 495 |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
496 These functions are now implemented in C; their Lisp implementations in this |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
497 XEmacs are trivial, so we provide them and mark them obsolete." |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
498 (let (symbol result) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
499 (while symbols |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
500 (setq symbol (car symbols) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
501 symbols (cdr symbols)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
502 (push `(make-obsolete ',(intern (format "%s*" symbol)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
503 ',symbol "21.5.29") |
|
4800
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
504 result) |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
505 (push |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
506 `(defun ,(intern (format "%s*" symbol)) (number &optional divisor) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
507 ,(format "See `%s'. This returns a list, not multiple values." |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
508 symbol) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
509 (multiple-value-list (,symbol number divisor))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
510 result)) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
511 (cons 'progn result)))) |
|
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
512 ceiling floor round truncate) |
| 428 | 513 |
| 514 (defun mod* (x y) | |
| 515 "The remainder of X divided by Y, with the same sign as Y." | |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
516 (nth-value 1 (floor x y))) |
| 428 | 517 |
| 518 (defun rem* (x y) | |
| 519 "The remainder of X divided by Y, with the same sign as X." | |
|
4678
b5e1d4f6b66f
Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2367
diff
changeset
|
520 (nth-value 1 (truncate x y))) |
| 428 | 521 |
| 522 (defun signum (a) | |
| 523 "Return 1 if A is positive, -1 if negative, 0 if zero." | |
| 524 (cond ((> a 0) 1) ((< a 0) -1) (t 0))) | |
| 525 | |
| 526 ;; Random numbers. | |
| 527 | |
| 528 (defvar *random-state*) | |
| 529 (defun random* (lim &optional state) | |
| 530 "Return a random nonnegative number less than LIM, an integer or float. | |
| 531 Optional second arg STATE is a random-state object." | |
| 532 (or state (setq state *random-state*)) | |
| 533 ;; Inspired by "ran3" from Numerical Recipes. Additive congruential method. | |
| 534 (let ((vec (aref state 3))) | |
| 535 (if (integerp vec) | |
| 536 (let ((i 0) (j (- 1357335 (% (abs vec) 1357333))) (k 1)) | |
| 537 (aset state 3 (setq vec (make-vector 55 nil))) | |
| 538 (aset vec 0 j) | |
| 539 (while (> (setq i (% (+ i 21) 55)) 0) | |
| 540 (aset vec i (setq j (prog1 k (setq k (- j k)))))) | |
| 541 (while (< (setq i (1+ i)) 200) (random* 2 state)))) | |
| 542 (let* ((i (aset state 1 (% (1+ (aref state 1)) 55))) | |
| 543 (j (aset state 2 (% (1+ (aref state 2)) 55))) | |
| 544 (n (logand 8388607 (aset vec i (- (aref vec i) (aref vec j)))))) | |
| 545 (if (integerp lim) | |
| 546 (if (<= lim 512) (% n lim) | |
| 547 (if (> lim 8388607) (setq n (+ (lsh n 9) (random* 512 state)))) | |
| 548 (let ((mask 1023)) | |
| 549 (while (< mask (1- lim)) (setq mask (1+ (+ mask mask)))) | |
| 550 (if (< (setq n (logand n mask)) lim) n (random* lim state)))) | |
| 551 (* (/ n '8388608e0) lim))))) | |
| 552 | |
| 553 (defun make-random-state (&optional state) | |
| 554 "Return a copy of random-state STATE, or of `*random-state*' if omitted. | |
| 555 If STATE is t, return a new state object seeded from the time of day." | |
| 556 (cond ((null state) (make-random-state *random-state*)) | |
| 557 ((vectorp state) (cl-copy-tree state t)) | |
| 558 ((integerp state) (vector 'cl-random-state-tag -1 30 state)) | |
| 559 (t (make-random-state (cl-random-time))))) | |
| 560 | |
| 561 (defun random-state-p (object) | |
| 562 "Return t if OBJECT is a random-state object." | |
| 563 (and (vectorp object) (= (length object) 4) | |
| 564 (eq (aref object 0) 'cl-random-state-tag))) | |
| 565 | |
| 566 | |
| 567 ;; Implementation limits. | |
| 568 | |
| 569 (defun cl-finite-do (func a b) | |
| 570 (condition-case nil | |
| 571 (let ((res (funcall func a b))) ; check for IEEE infinity | |
| 572 (and (numberp res) (/= res (/ res 2)) res)) | |
| 573 (arith-error nil))) | |
| 574 | |
| 575 (defvar most-positive-float) | |
| 576 (defvar most-negative-float) | |
| 577 (defvar least-positive-float) | |
| 578 (defvar least-negative-float) | |
| 579 (defvar least-positive-normalized-float) | |
| 580 (defvar least-negative-normalized-float) | |
| 581 (defvar float-epsilon) | |
| 582 (defvar float-negative-epsilon) | |
| 583 | |
| 584 (defun cl-float-limits () | |
| 585 (or most-positive-float (not (numberp '2e1)) | |
| 586 (let ((x '2e0) y z) | |
| 587 ;; Find maximum exponent (first two loops are optimizations) | |
| 588 (while (cl-finite-do '* x x) (setq x (* x x))) | |
| 589 (while (cl-finite-do '* x (/ x 2)) (setq x (* x (/ x 2)))) | |
| 590 (while (cl-finite-do '+ x x) (setq x (+ x x))) | |
| 591 (setq z x y (/ x 2)) | |
| 592 ;; Now fill in 1's in the mantissa. | |
| 593 (while (and (cl-finite-do '+ x y) (/= (+ x y) x)) | |
| 594 (setq x (+ x y) y (/ y 2))) | |
| 595 (setq most-positive-float x | |
| 596 most-negative-float (- x)) | |
| 597 ;; Divide down until mantissa starts rounding. | |
| 598 (setq x (/ x z) y (/ 16 z) x (* x y)) | |
| 599 (while (condition-case nil (and (= x (* (/ x 2) 2)) (> (/ y 2) 0)) | |
| 600 (arith-error nil)) | |
| 601 (setq x (/ x 2) y (/ y 2))) | |
| 602 (setq least-positive-normalized-float y | |
| 603 least-negative-normalized-float (- y)) | |
| 604 ;; Divide down until value underflows to zero. | |
| 605 (setq x (/ 1 z) y x) | |
| 606 (while (condition-case nil (> (/ x 2) 0) (arith-error nil)) | |
| 607 (setq x (/ x 2))) | |
| 608 (setq least-positive-float x | |
| 609 least-negative-float (- x)) | |
| 610 (setq x '1e0) | |
| 611 (while (/= (+ '1e0 x) '1e0) (setq x (/ x 2))) | |
| 612 (setq float-epsilon (* x 2)) | |
| 613 (setq x '1e0) | |
| 614 (while (/= (- '1e0 x) '1e0) (setq x (/ x 2))) | |
| 615 (setq float-negative-epsilon (* x 2)))) | |
| 616 nil) | |
| 617 | |
| 618 | |
| 619 ;;; Sequence functions. | |
| 620 | |
| 621 ;XEmacs -- our built-in is more powerful. | |
| 622 ;(defun subseq (seq start &optional end) | |
| 623 ; "Return the subsequence of SEQ from START to END. | |
| 624 ;If END is omitted, it defaults to the length of the sequence. | |
| 625 ;If START or END is negative, it counts from the end." | |
| 626 ; (if (stringp seq) (substring seq start end) | |
| 627 ; (let (len) | |
| 628 ; (and end (< end 0) (setq end (+ end (setq len (length seq))))) | |
| 629 ; (if (< start 0) (setq start (+ start (or len (setq len (length seq)))))) | |
| 630 ; (cond ((listp seq) | |
| 631 ; (if (> start 0) (setq seq (nthcdr start seq))) | |
| 632 ; (if end | |
| 633 ; (let ((res nil)) | |
| 634 ; (while (>= (setq end (1- end)) start) | |
| 2153 | 635 ; (push (pop seq) res)) |
| 428 | 636 ; (nreverse res)) |
| 637 ; (copy-sequence seq))) | |
| 638 ; (t | |
| 639 ; (or end (setq end (or len (length seq)))) | |
| 640 ; (let ((res (make-vector (max (- end start) 0) nil)) | |
| 641 ; (i 0)) | |
| 642 ; (while (< start end) | |
| 643 ; (aset res i (aref seq start)) | |
| 644 ; (setq i (1+ i) start (1+ start))) | |
| 645 ; res)))))) | |
| 646 | |
| 647 (defun concatenate (type &rest seqs) | |
| 648 "Concatenate, into a sequence of type TYPE, the argument SEQUENCES." | |
| 2153 | 649 ;; XEmacs change: use case instead of cond for clarity |
| 428 | 650 (case type |
| 651 (vector (apply 'vconcat seqs)) | |
| 652 (string (apply 'concat seqs)) | |
| 653 (list (apply 'append (append seqs '(nil)))) | |
| 654 (t (error "Not a sequence type name: %s" type)))) | |
| 655 | |
| 656 ;;; List functions. | |
| 657 | |
| 658 (defun revappend (x y) | |
| 659 "Equivalent to (append (reverse X) Y)." | |
| 660 (nconc (reverse x) y)) | |
| 661 | |
| 662 (defun nreconc (x y) | |
| 663 "Equivalent to (nconc (nreverse X) Y)." | |
| 664 (nconc (nreverse x) y)) | |
| 665 | |
| 666 (defun list-length (x) | |
| 667 "Return the length of a list. Return nil if list is circular." | |
| 668 (let ((n 0) (fast x) (slow x)) | |
| 669 (while (and (cdr fast) (not (and (eq fast slow) (> n 0)))) | |
| 670 (setq n (+ n 2) fast (cdr (cdr fast)) slow (cdr slow))) | |
| 671 (if fast (if (cdr fast) nil (1+ n)) n))) | |
| 672 | |
| 673 (defun tailp (sublist list) | |
| 674 "Return true if SUBLIST is a tail of LIST." | |
| 675 (while (and (consp list) (not (eq sublist list))) | |
| 676 (setq list (cdr list))) | |
| 677 (if (numberp sublist) (equal sublist list) (eq sublist list))) | |
| 678 | |
| 2153 | 679 (defalias 'cl-copy-tree 'copy-tree) |
| 428 | 680 |
| 681 | |
| 682 ;;; Property lists. | |
| 683 | |
| 684 ;; XEmacs: our `get' groks DEFAULT. | |
| 685 (defalias 'get* 'get) | |
| 442 | 686 (defalias 'getf 'plist-get) |
| 428 | 687 |
| 688 (defun cl-set-getf (plist tag val) | |
| 689 (let ((p plist)) | |
| 690 (while (and p (not (eq (car p) tag))) (setq p (cdr (cdr p)))) | |
| 691 (if p (progn (setcar (cdr p) val) plist) (list* tag val plist)))) | |
| 692 | |
| 693 (defun cl-do-remf (plist tag) | |
| 694 (let ((p (cdr plist))) | |
| 695 (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p)))) | |
| 696 (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t)))) | |
| 697 | |
| 2153 | 698 ;; XEmacs change: we have a builtin remprop |
| 699 (defalias 'cl-remprop 'remprop) | |
| 700 | |
|
4800
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
701 (defun get-properties (plist indicator-list) |
|
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
702 "Find a property from INDICATOR-LIST in PLIST. |
|
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
703 Return 3 values: |
|
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
704 - the first property found, |
|
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
705 - its value, |
|
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
706 - the tail of PLIST beginning with the found entry." |
|
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
707 (do ((plst plist (cddr plst))) |
|
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
708 ((null plst) (values nil nil nil)) |
|
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
709 (cond ((atom (cdr plst)) |
|
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
710 (error "Malformed property list: %S." plist)) |
|
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
711 ((memq (car plst) indicator-list) |
|
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
712 (return (values (car plst) (cadr plst) plst)))))) |
| 2153 | 713 |
| 714 | |
| 428 | 715 ;;; Hash tables. |
| 716 | |
| 717 ;; The `regular' Common Lisp hash-table stuff has been moved into C. | |
| 718 ;; Only backward compatibility stuff remains here. | |
| 719 (defun make-hashtable (size &optional test) | |
| 720 (make-hash-table :test test :size size)) | |
| 721 (defun make-weak-hashtable (size &optional test) | |
| 722 (make-hash-table :test test :size size :weakness t)) | |
| 723 (defun make-key-weak-hashtable (size &optional test) | |
| 724 (make-hash-table :test test :size size :weakness 'key)) | |
| 725 (defun make-value-weak-hashtable (size &optional test) | |
| 726 (make-hash-table :test test :size size :weakness 'value)) | |
| 727 | |
| 728 (define-obsolete-function-alias 'hashtablep 'hash-table-p) | |
| 729 (define-obsolete-function-alias 'hashtable-fullness 'hash-table-count) | |
| 730 (define-obsolete-function-alias 'hashtable-test-function 'hash-table-test) | |
| 731 (define-obsolete-function-alias 'hashtable-type 'hash-table-type) | |
| 732 (define-obsolete-function-alias 'hashtable-size 'hash-table-size) | |
| 733 (define-obsolete-function-alias 'copy-hashtable 'copy-hash-table) | |
| 734 | |
| 735 (make-obsolete 'make-hashtable 'make-hash-table) | |
| 736 (make-obsolete 'make-weak-hashtable 'make-hash-table) | |
| 737 (make-obsolete 'make-key-weak-hashtable 'make-hash-table) | |
| 738 (make-obsolete 'make-value-weak-hashtable 'make-hash-table) | |
| 739 (make-obsolete 'hash-table-type 'hash-table-weakness) | |
| 740 | |
| 741 (when (fboundp 'x-keysym-hash-table) | |
| 742 (make-obsolete 'x-keysym-hashtable 'x-keysym-hash-table)) | |
| 743 | |
| 744 ;; Compatibility stuff for old kludgy cl.el hash table implementation | |
| 745 (defvar cl-builtin-gethash (symbol-function 'gethash)) | |
| 746 (defvar cl-builtin-remhash (symbol-function 'remhash)) | |
| 747 (defvar cl-builtin-clrhash (symbol-function 'clrhash)) | |
| 748 (defvar cl-builtin-maphash (symbol-function 'maphash)) | |
| 749 | |
| 750 (defalias 'cl-gethash 'gethash) | |
| 751 (defalias 'cl-puthash 'puthash) | |
| 752 (defalias 'cl-remhash 'remhash) | |
| 753 (defalias 'cl-clrhash 'clrhash) | |
| 754 (defalias 'cl-maphash 'maphash) | |
| 2153 | 755 ;; These three actually didn't exist in Emacs-20. |
| 756 (defalias 'cl-make-hash-table 'make-hash-table) | |
| 757 (defalias 'cl-hash-table-p 'hash-table-p) | |
| 758 (defalias 'cl-hash-table-count 'hash-table-count) | |
| 428 | 759 |
| 760 ;;; Some debugging aids. | |
| 761 | |
| 762 (defun cl-prettyprint (form) | |
| 763 "Insert a pretty-printed rendition of a Lisp FORM in current buffer." | |
| 764 (let ((pt (point)) last) | |
| 765 (insert "\n" (prin1-to-string form) "\n") | |
| 766 (setq last (point)) | |
| 767 (goto-char (1+ pt)) | |
| 768 (while (search-forward "(quote " last t) | |
| 769 (delete-backward-char 7) | |
| 770 (insert "'") | |
| 771 (forward-sexp) | |
| 772 (delete-char 1)) | |
| 773 (goto-char (1+ pt)) | |
| 774 (cl-do-prettyprint))) | |
| 775 | |
| 776 (defun cl-do-prettyprint () | |
| 777 (skip-chars-forward " ") | |
| 778 (if (looking-at "(") | |
|
4800
b828e06dbe38
New (Common Lisp) function get-propertie
Didier Verna <didier@xemacs.org>
parents:
4792
diff
changeset
|
779 (let ((skip (or (looking-at "((") |
| 2153 | 780 ;; XEmacs: be selective about trailing stuff after prog |
| 1729 | 781 (looking-at "(prog[nv12\\(ress-feedback\\|n-with-message\\)]") |
| 428 | 782 (looking-at "(unwind-protect ") |
| 783 (looking-at "(function (") | |
| 784 (looking-at "(cl-block-wrapper "))) | |
| 785 (two (or (looking-at "(defun ") (looking-at "(defmacro "))) | |
| 786 (let (or (looking-at "(let\\*? ") (looking-at "(while "))) | |
| 787 (set (looking-at "(p?set[qf] "))) | |
| 788 (if (or skip let | |
| 789 (progn | |
| 790 (forward-sexp) | |
| 791 (and (>= (current-column) 78) (progn (backward-sexp) t)))) | |
| 792 (let ((nl t)) | |
| 793 (forward-char 1) | |
| 794 (cl-do-prettyprint) | |
| 795 (or skip (looking-at ")") (cl-do-prettyprint)) | |
| 796 (or (not two) (looking-at ")") (cl-do-prettyprint)) | |
| 797 (while (not (looking-at ")")) | |
| 798 (if set (setq nl (not nl))) | |
| 799 (if nl (insert "\n")) | |
| 800 (lisp-indent-line) | |
| 801 (cl-do-prettyprint)) | |
| 802 (forward-char 1)))) | |
| 803 (forward-sexp))) | |
| 804 | |
| 805 (defvar cl-macroexpand-cmacs nil) | |
| 806 (defvar cl-closure-vars nil) | |
| 807 | |
| 808 (defun cl-macroexpand-all (form &optional env) | |
| 809 "Expand all macro calls through a Lisp FORM. | |
| 810 This also does some trivial optimizations to make the form prettier." | |
| 811 (while (or (not (eq form (setq form (macroexpand form env)))) | |
| 812 (and cl-macroexpand-cmacs | |
| 813 (not (eq form (setq form (compiler-macroexpand form))))))) | |
| 814 (cond ((not (consp form)) form) | |
| 815 ((memq (car form) '(let let*)) | |
| 816 (if (null (nth 1 form)) | |
| 817 (cl-macroexpand-all (cons 'progn (cddr form)) env) | |
| 818 (let ((letf nil) (res nil) (lets (cadr form))) | |
| 819 (while lets | |
| 2153 | 820 (push (if (consp (car lets)) |
| 428 | 821 (let ((exp (cl-macroexpand-all (caar lets) env))) |
| 822 (or (symbolp exp) (setq letf t)) | |
| 823 (cons exp (cl-macroexpand-body (cdar lets) env))) | |
| 824 (let ((exp (cl-macroexpand-all (car lets) env))) | |
| 825 (if (symbolp exp) exp | |
| 826 (setq letf t) (list exp nil)))) res) | |
| 827 (setq lets (cdr lets))) | |
| 828 (list* (if letf (if (eq (car form) 'let) 'letf 'letf*) (car form)) | |
| 829 (nreverse res) (cl-macroexpand-body (cddr form) env))))) | |
| 830 ((eq (car form) 'cond) | |
| 831 (cons (car form) | |
| 832 (mapcar (function (lambda (x) (cl-macroexpand-body x env))) | |
| 833 (cdr form)))) | |
| 834 ((eq (car form) 'condition-case) | |
| 835 (list* (car form) (nth 1 form) (cl-macroexpand-all (nth 2 form) env) | |
| 836 (mapcar (function | |
| 837 (lambda (x) | |
| 838 (cons (car x) (cl-macroexpand-body (cdr x) env)))) | |
| 839 (cdddr form)))) | |
| 840 ((memq (car form) '(quote function)) | |
| 841 (if (eq (car-safe (nth 1 form)) 'lambda) | |
| 842 (let ((body (cl-macroexpand-body (cddadr form) env))) | |
| 843 (if (and cl-closure-vars (eq (car form) 'function) | |
| 844 (cl-expr-contains-any body cl-closure-vars)) | |
| 845 (let* ((new (mapcar 'gensym cl-closure-vars)) | |
| 846 (sub (pairlis cl-closure-vars new)) (decls nil)) | |
| 847 (while (or (stringp (car body)) | |
| 848 (eq (car-safe (car body)) 'interactive)) | |
| 2153 | 849 (push (list 'quote (pop body)) decls)) |
| 428 | 850 (put (car (last cl-closure-vars)) 'used t) |
| 851 (append | |
| 852 (list 'list '(quote lambda) '(quote (&rest --cl-rest--))) | |
| 853 (sublis sub (nreverse decls)) | |
| 854 (list | |
| 855 (list* 'list '(quote apply) | |
| 2153 | 856 ;; XEmacs: put a quote before the function |
| 428 | 857 (list 'list '(quote quote) |
| 858 (list 'function | |
| 859 (list* 'lambda | |
| 860 (append new (cadadr form)) | |
| 861 (sublis sub body)))) | |
| 862 (nconc (mapcar (function | |
| 863 (lambda (x) | |
| 864 (list 'list '(quote quote) x))) | |
| 865 cl-closure-vars) | |
| 866 '((quote --cl-rest--))))))) | |
| 867 (list (car form) (list* 'lambda (cadadr form) body)))) | |
| 868 (let ((found (assq (cadr form) env))) | |
| 2153 | 869 ;; XEmacs: cadr/caddr operate on nil without errors |
| 428 | 870 (if (eq (cadr (caddr found)) 'cl-labels-args) |
| 871 (cl-macroexpand-all (cadr (caddr (cadddr found))) env) | |
| 872 form)))) | |
| 873 ((memq (car form) '(defun defmacro)) | |
| 874 (list* (car form) (nth 1 form) (cl-macroexpand-body (cddr form) env))) | |
| 875 ((and (eq (car form) 'progn) (not (cddr form))) | |
| 876 (cl-macroexpand-all (nth 1 form) env)) | |
| 877 ((eq (car form) 'setq) | |
| 878 (let* ((args (cl-macroexpand-body (cdr form) env)) (p args)) | |
| 879 (while (and p (symbolp (car p))) (setq p (cddr p))) | |
| 880 (if p (cl-macroexpand-all (cons 'setf args)) (cons 'setq args)))) | |
| 881 (t (cons (car form) (cl-macroexpand-body (cdr form) env))))) | |
| 882 | |
| 883 (defun cl-macroexpand-body (body &optional env) | |
| 884 (mapcar (function (lambda (x) (cl-macroexpand-all x env))) body)) | |
| 885 | |
| 886 (defun cl-prettyexpand (form &optional full) | |
| 887 (message "Expanding...") | |
| 888 (let ((cl-macroexpand-cmacs full) (cl-compiling-file full) | |
| 889 (byte-compile-macro-environment nil)) | |
| 890 (setq form (cl-macroexpand-all form | |
| 891 (and (not full) '((block) (eval-when))))) | |
| 892 (message "Formatting...") | |
| 893 (prog1 (cl-prettyprint form) | |
| 894 (message "")))) | |
| 895 | |
| 896 | |
| 897 | |
| 898 (run-hooks 'cl-extra-load-hook) | |
| 899 | |
| 2153 | 900 ;; XEmacs addition |
| 428 | 901 (provide 'cl-extra) |
| 902 | |
| 2153 | 903 ;;; arch-tag: bcd03437-0871-43fb-a8f1-ad0e0b5427ed |
| 428 | 904 ;;; cl-extra.el ends here |