Mercurial > hg > xemacs-beta
annotate lisp/syntax.el @ 5013:ae48681c47fa
changes to VOID_TO_LISP et al.
-------------------- ChangeLog entries follow: --------------------
src/ChangeLog addition:
2010-02-08 Ben Wing <ben@xemacs.org>
* casetab.c (compute_canon_mapper):
* casetab.c (initialize_identity_mapper):
* casetab.c (compute_up_or_eqv_mapper):
* casetab.c (recompute_case_table):
* casetab.c (set_case_table):
* chartab.c (copy_mapper):
* chartab.c (copy_char_table_range):
* chartab.c (get_range_char_table_1):
* console.c (find_nonminibuffer_frame_not_on_console_predicate):
* console.c (find_nonminibuffer_frame_not_on_console):
* console.c (nuke_all_console_slots):
* device.c:
* device.c (find_nonminibuffer_frame_not_on_device_predicate):
* device.c (find_nonminibuffer_frame_not_on_device):
* dialog-msw.c (dialog_proc):
* dialog-msw.c (handle_question_dialog_box):
* dialog-x.c (maybe_run_dbox_text_callback):
* eval.c:
* eval.c (safe_run_hook_trapping_problems_1):
* eval.c (safe_run_hook_trapping_problems):
* event-msw.c:
* event-msw.c (mswindows_wnd_proc):
* event-msw.c (mswindows_find_frame):
* faces.c (update_face_inheritance_mapper):
* frame-msw.c (mswindows_init_frame_1):
* frame-msw.c (mswindows_get_mouse_position):
* frame-msw.c (mswindows_get_frame_parent):
* glade.c (connector):
* glade.c (Fglade_xml_signal_connect):
* glade.c (Fglade_xml_signal_autoconnect):
* glade.c (Fglade_xml_textdomain):
* glyphs-msw.c (mswindows_subwindow_instantiate):
* glyphs-msw.c (mswindows_widget_instantiate):
* glyphs.c (check_instance_cache_mapper):
* glyphs.c (check_window_subwindow_cache):
* glyphs.c (check_image_instance_structure):
* gui-x.c (snarf_widget_value_mapper):
* gui-x.c (popup_selection_callback):
* gui-x.c (button_item_to_widget_value):
* keymap.c (map_keymap_mapper):
* keymap.c (Fmap_keymap):
* menubar-gtk.c (__torn_off_sir):
* menubar-gtk.c (__activate_menu):
* menubar-gtk.c (menu_convert):
* menubar-gtk.c (__generic_button_callback):
* menubar-gtk.c (menu_descriptor_to_widget_1):
* menubar-msw.c:
* menubar-msw.c (EMPTY_ITEM_ID):
* menubar-x.c (menu_item_descriptor_to_widget_value_1):
* menubar-x.c (pre_activate_callback):
* menubar-x.c (command_builder_operate_menu_accelerator):
* menubar-x.c (command_builder_find_menu_accelerator):
* print.c (print_internal):
* process-unix.c (close_process_descs_mapfun):
* process.c (get_process_from_usid):
* process.c (init_process_io_handles):
* profile.c (sigprof_handler):
* profile.c (get_profiling_info_timing_maphash):
* profile.c (Fget_profiling_info):
* profile.c (set_profiling_info_timing_maphash):
* profile.c (mark_profiling_info_maphash):
* scrollbar-msw.c (mswindows_create_scrollbar_instance):
* scrollbar-msw.c (mswindows_free_scrollbar_instance):
* scrollbar-msw.c (mswindows_handle_scrollbar_event):
* specifier.c (recompute_cached_specifier_everywhere_mapfun):
* specifier.c (recompute_cached_specifier_everywhere):
* syntax.c (copy_to_mirrortab):
* syntax.c (copy_if_not_already_present):
* syntax.c (update_just_this_syntax_table):
* text.c (new_dfc_convert_now_damn_it):
* text.h (LISP_STRING_TO_EXTERNAL):
* tooltalk.c:
* tooltalk.c (tooltalk_message_callback):
* tooltalk.c (tooltalk_pattern_callback):
* tooltalk.c (Fcreate_tooltalk_message):
* tooltalk.c (Fcreate_tooltalk_pattern):
* ui-byhand.c (__generic_toolbar_callback):
* ui-byhand.c (generic_toolbar_insert_item):
* ui-byhand.c (__emacs_gtk_ctree_recurse_internal):
* ui-byhand.c (Fgtk_ctree_recurse):
* ui-gtk.c (__internal_callback_destroy):
* ui-gtk.c (__internal_callback_marshal):
* ui-gtk.c (Fgtk_signal_connect):
* ui-gtk.c (gtk_type_to_lisp):
* ui-gtk.c (lisp_to_gtk_type):
* ui-gtk.c (lisp_to_gtk_ret_type):
* lisp-disunion.h:
* lisp-disunion.h (NON_LVALUE):
* lisp-union.h:
* lisp.h (LISP_HASH):
Rename:
LISP_TO_VOID -> STORE_LISP_IN_VOID
VOID_TO_LISP -> GET_LISP_FROM_VOID
These new names are meant to clearly identify that the Lisp object
is the source and void the sink, and that they can't be used the
other way around -- they aren't exact opposites despite the old
names. The names are also important given the new functions
created just below. Also, clarify comments in lisp-union.h and
lisp-disunion.h about the use of the functions.
* lisp.h:
New functions STORE_VOID_IN_LISP and GET_VOID_FROM_LISP. These
are different from the above in that the source is a void *
(previously, you had to use make_opaque_ptr()).
* eval.c (restore_lisp_object):
* eval.c (record_unwind_protect_restoring_lisp_object):
* eval.c (struct restore_int):
* eval.c (restore_int):
* eval.c (record_unwind_protect_restoring_int):
* eval.c (free_pointer):
* eval.c (record_unwind_protect_freeing):
* eval.c (free_dynarr):
* eval.c (record_unwind_protect_freeing_dynarr):
* eval.c (unbind_to_1):
Use STORE_VOID_IN_LISP and GET_VOID_FROM_LISP to eliminate the
use of make_opaque_ptr() and mostly eliminate Lisp consing
entirely in the use of these various record_unwind_protect_*
functions as well as internal_bind_* (e.g. internal_bind_int).
* tests.c:
* tests.c (Ftest_store_void_in_lisp):
* tests.c (syms_of_tests):
* tests.c (vars_of_tests):
Add an C-assert-style test to test STORE_VOID_IN_LISP and
GET_VOID_FROM_LISP to make sure the same value comes back that
was put in.
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Mon, 08 Feb 2010 06:42:16 -0600 |
| parents | 99e465e2da2e |
| children | 308d34e9f07d |
| rev | line source |
|---|---|
| 428 | 1 ;; syntax.el --- Syntax-table hacking stuff, moved from syntax.c |
| 2 | |
| 3 ;; Copyright (C) 1993, 1997 Free Software Foundation, Inc. | |
| 4 ;; Copyright (C) 1995 Sun Microsystems. | |
|
4945
99e465e2da2e
(main branch) Update make-syntax-table doc
Ben Wing <ben@xemacs.org>
parents:
4806
diff
changeset
|
5 ;; Copyright (C) 2005, 2010 Ben Wing. |
| 428 | 6 |
| 7 ;; This file is part of XEmacs. | |
| 8 | |
| 9 ;; XEmacs is free software; you can redistribute it and/or modify it | |
| 10 ;; under the terms of the GNU General Public License as published by | |
| 11 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 12 ;; any later version. | |
| 13 | |
| 14 ;; XEmacs is distributed in the hope that it will be useful, but | |
| 15 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
| 17 ;; General Public License for more details. | |
| 18 | |
| 19 ;; You should have received a copy of the GNU General Public License | |
| 444 | 20 ;; along with XEmacs; see the file COPYING. If not, write to the |
| 428 | 21 ;; Free Software Foundation, 59 Temple Place - Suite 330, |
| 22 ;; Boston, MA 02111-1307, USA. | |
| 23 | |
| 24 ;;; Synched up with: FSF 19.28. | |
| 25 | |
| 26 ;;; Commentary: | |
| 27 | |
| 28 ;; This file is dumped with XEmacs. | |
| 29 | |
| 30 ;; Note: FSF does not have a file syntax.el. This stuff is | |
| 31 ;; in syntax.c. See comments there about not merging past 19.28. | |
| 32 | |
| 33 ;; Significantly hacked upon by Ben Wing. | |
| 34 | |
| 35 ;;; Code: | |
| 36 | |
| 37 (defun make-syntax-table (&optional oldtable) | |
| 38 "Return a new syntax table. | |
|
4945
99e465e2da2e
(main branch) Update make-syntax-table doc
Ben Wing <ben@xemacs.org>
parents:
4806
diff
changeset
|
39 |
|
99e465e2da2e
(main branch) Update make-syntax-table doc
Ben Wing <ben@xemacs.org>
parents:
4806
diff
changeset
|
40 It inherits all characters from the standard syntax table. |
|
99e465e2da2e
(main branch) Update make-syntax-table doc
Ben Wing <ben@xemacs.org>
parents:
4806
diff
changeset
|
41 |
|
99e465e2da2e
(main branch) Update make-syntax-table doc
Ben Wing <ben@xemacs.org>
parents:
4806
diff
changeset
|
42 A syntax table is a char table of type `syntax' (see `make-char-table'). |
|
99e465e2da2e
(main branch) Update make-syntax-table doc
Ben Wing <ben@xemacs.org>
parents:
4806
diff
changeset
|
43 The valid values are integers (intended to be syntax codes as generated by |
|
99e465e2da2e
(main branch) Update make-syntax-table doc
Ben Wing <ben@xemacs.org>
parents:
4806
diff
changeset
|
44 `syntax-string-to-code'), and the default result given by `get-char-table' |
|
99e465e2da2e
(main branch) Update make-syntax-table doc
Ben Wing <ben@xemacs.org>
parents:
4806
diff
changeset
|
45 is the syntax code for `word'. (Note: In 21.4 and prior, it was the code |
|
99e465e2da2e
(main branch) Update make-syntax-table doc
Ben Wing <ben@xemacs.org>
parents:
4806
diff
changeset
|
46 for `inherit'.) |
|
99e465e2da2e
(main branch) Update make-syntax-table doc
Ben Wing <ben@xemacs.org>
parents:
4806
diff
changeset
|
47 |
|
99e465e2da2e
(main branch) Update make-syntax-table doc
Ben Wing <ben@xemacs.org>
parents:
4806
diff
changeset
|
48 To modify a syntax table, you should normally use `modify-syntax-entry' |
|
99e465e2da2e
(main branch) Update make-syntax-table doc
Ben Wing <ben@xemacs.org>
parents:
4806
diff
changeset
|
49 rather than directly modify the table with `put-char-table'. |
|
99e465e2da2e
(main branch) Update make-syntax-table doc
Ben Wing <ben@xemacs.org>
parents:
4806
diff
changeset
|
50 |
|
99e465e2da2e
(main branch) Update make-syntax-table doc
Ben Wing <ben@xemacs.org>
parents:
4806
diff
changeset
|
51 See `modify-syntax-entry' for a description of the character codes used |
|
99e465e2da2e
(main branch) Update make-syntax-table doc
Ben Wing <ben@xemacs.org>
parents:
4806
diff
changeset
|
52 to indicate the various syntax classes." |
| 428 | 53 (make-char-table 'syntax)) |
| 54 | |
|
4468
a78d697ccd2c
Import and extend GNU's descr-text.el, supporting prefix argument for C-x =
Aidan Kehoe <kehoea@parhasard.net>
parents:
3067
diff
changeset
|
55 (defun syntax-after (pos) |
|
a78d697ccd2c
Import and extend GNU's descr-text.el, supporting prefix argument for C-x =
Aidan Kehoe <kehoea@parhasard.net>
parents:
3067
diff
changeset
|
56 "Return the raw syntax of the char after POS. |
|
a78d697ccd2c
Import and extend GNU's descr-text.el, supporting prefix argument for C-x =
Aidan Kehoe <kehoea@parhasard.net>
parents:
3067
diff
changeset
|
57 If POS is outside the buffer's accessible portion, return nil." |
|
a78d697ccd2c
Import and extend GNU's descr-text.el, supporting prefix argument for C-x =
Aidan Kehoe <kehoea@parhasard.net>
parents:
3067
diff
changeset
|
58 (unless (or (< pos (point-min)) (>= pos (point-max))) |
|
a78d697ccd2c
Import and extend GNU's descr-text.el, supporting prefix argument for C-x =
Aidan Kehoe <kehoea@parhasard.net>
parents:
3067
diff
changeset
|
59 (let ((st (if lookup-syntax-properties |
|
a78d697ccd2c
Import and extend GNU's descr-text.el, supporting prefix argument for C-x =
Aidan Kehoe <kehoea@parhasard.net>
parents:
3067
diff
changeset
|
60 (get-char-property pos 'syntax-table)))) |
|
a78d697ccd2c
Import and extend GNU's descr-text.el, supporting prefix argument for C-x =
Aidan Kehoe <kehoea@parhasard.net>
parents:
3067
diff
changeset
|
61 (char-syntax (char-after pos) (or st (syntax-table)))))) |
|
a78d697ccd2c
Import and extend GNU's descr-text.el, supporting prefix argument for C-x =
Aidan Kehoe <kehoea@parhasard.net>
parents:
3067
diff
changeset
|
62 |
| 428 | 63 (defun simple-set-syntax-entry (char spec table) |
| 64 (put-char-table char spec table)) | |
| 65 | |
| 66 (defun char-syntax-from-code (code) | |
| 67 "Extract the syntax designator from the internal syntax code CODE. | |
| 68 CODE is the value actually contained in the syntax table." | |
| 69 (if (consp code) | |
| 70 (setq code (car code))) | |
| 71 (aref (syntax-designator-chars) (logand code 127))) | |
| 72 | |
| 73 (defun set-char-syntax-in-code (code desig) | |
| 74 "Return a new internal syntax code whose syntax designator is DESIG. | |
| 75 Other characteristics are the same as in CODE." | |
| 76 (let ((newcode (if (consp code) (car code) code))) | |
| 77 (setq newcode (logior (string-match | |
| 78 (regexp-quote (char-to-string desig)) | |
| 79 (syntax-designator-chars)) | |
| 80 (logand newcode (lognot 127)))) | |
| 81 (if (consp code) (cons newcode (cdr code)) | |
| 82 newcode))) | |
| 83 | |
| 84 (defun syntax-code-to-string (code) | |
| 85 "Return a string equivalent to internal syntax code CODE. | |
| 86 The string can be passed to `modify-syntax-entry'. | |
| 87 If CODE is invalid, return nil." | |
| 88 (let ((match (and (consp code) (cdr code))) | |
| 89 (codes (syntax-designator-chars))) | |
| 90 (if (consp code) | |
| 91 (setq code (car code))) | |
| 92 (if (or (not (integerp code)) | |
| 93 (> (logand code 127) (length codes))) | |
| 94 nil | |
| 95 (with-output-to-string | |
| 96 (let* ((spec (elt codes (logand code 127))) | |
| 97 (b3 (lsh code -16)) | |
| 98 (start1 (/= 0 (logand b3 128))) ;logtest! | |
| 99 (start1b (/= 0 (logand b3 64))) | |
| 100 (start2 (/= 0 (logand b3 32))) | |
| 101 (start2b (/= 0 (logand b3 16))) | |
| 102 (end1 (/= 0 (logand b3 8))) | |
| 103 (end1b (/= 0 (logand b3 4))) | |
| 104 (end2 (/= 0 (logand b3 2))) | |
| 105 (end2b (/= 0 (logand b3 1))) | |
| 106 (prefix (/= 0 (logand code 128))) | |
| 107 (single-char-p (or (= spec ?<) (= spec ?>))) | |
| 108 ) | |
| 109 (write-char spec) | |
| 110 (write-char (if match match 32)) | |
| 111 ;;; (if start1 (if single-char-p (write-char ?a) (write-char ?1))) | |
| 112 (if start1 (if single-char-p (write-char ? ) (write-char ?1))) | |
| 113 (if start2 (write-char ?2)) | |
| 114 ;;; (if end1 (if single-char-p (write-char ?a) (write-char ?3))) | |
| 115 (if end1 (if single-char-p (write-char ? ) (write-char ?3))) | |
| 116 (if end2 (write-char ?4)) | |
| 117 (if start1b (if single-char-p (write-char ?b) (write-char ?5))) | |
| 118 (if start2b (write-char ?6)) | |
| 119 (if end1b (if single-char-p (write-char ?b) (write-char ?7))) | |
| 120 (if end2b (write-char ?8)) | |
| 121 (if prefix (write-char ?p))))))) | |
| 122 | |
| 123 (defun syntax-string-to-code (string) | |
| 124 "Return the internal syntax code equivalent to STRING. | |
| 125 STRING should be something acceptable as the second argument to | |
| 126 `modify-syntax-entry'. | |
| 127 If STRING is invalid, signal an error." | |
| 128 (let* ((bflag nil) | |
| 129 (b3 0) | |
| 130 (ch0 (aref string 0)) | |
| 131 (len (length string)) | |
| 132 (code (string-match (regexp-quote (char-to-string ch0)) | |
| 133 (syntax-designator-chars))) | |
| 134 (i 2) | |
| 135 ch) | |
| 136 (or code | |
| 137 (error "Invalid syntax designator: %S" string)) | |
| 138 (while (< i len) | |
| 139 (setq ch (aref string i)) | |
| 140 (incf i) | |
| 141 (case ch | |
| 142 (?1 (setq b3 (logior b3 128))) | |
| 143 (?2 (setq b3 (logior b3 32))) | |
| 144 (?3 (setq b3 (logior b3 8))) | |
| 145 (?4 (setq b3 (logior b3 2))) | |
| 146 (?5 (setq b3 (logior b3 64))) | |
| 147 (?6 (setq b3 (logior b3 16))) | |
| 148 (?7 (setq b3 (logior b3 4))) | |
| 149 (?8 (setq b3 (logior b3 1))) | |
| 150 (?a (case ch0 | |
| 151 (?< (setq b3 (logior b3 128))) | |
| 152 (?> (setq b3 (logior b3 8))))) | |
| 153 (?b (case ch0 | |
| 154 (?< (setq b3 (logior b3 64) bflag t)) | |
| 155 (?> (setq b3 (logior b3 4) bflag t)))) | |
| 156 (?p (setq code (logior code (lsh 1 7)))) | |
| 157 (?\ nil) ;; ignore for compatibility | |
| 158 (otherwise | |
| 159 (error "Invalid syntax description flag: %S" string)))) | |
| 160 ;; default single char style if `b' has not been seen | |
| 161 (if (not bflag) | |
| 162 (case ch0 | |
| 163 (?< (setq b3 (logior b3 128))) | |
| 164 (?> (setq b3 (logior b3 8))))) | |
| 165 (setq code (logior code (lsh b3 16))) | |
| 166 (if (and (> len 1) | |
| 167 ;; tough luck if you want to make space a paren! | |
| 168 (/= (aref string 1) ?\ )) | |
| 169 (setq code (cons code (aref string 1)))) | |
| 170 code)) | |
| 171 | |
| 444 | 172 (defun modify-syntax-entry (char-range spec &optional syntax-table) |
| 428 | 173 "Set syntax for the characters CHAR-RANGE according to string SPEC. |
| 174 CHAR-RANGE is a single character or a range of characters, | |
| 175 as per `put-char-table'. | |
| 444 | 176 The syntax is changed only for SYNTAX-TABLE, which defaults to |
| 428 | 177 the current buffer's syntax table. |
| 178 The first character of SPEC should be one of the following: | |
| 179 Space whitespace syntax. w word constituent. | |
| 180 _ symbol constituent. . punctuation. | |
| 181 \( open-parenthesis. \) close-parenthesis. | |
| 182 \" string quote. \\ character-quote. | |
| 183 $ paired delimiter. ' expression quote or prefix operator. | |
| 184 < comment starter. > comment ender. | |
| 185 / character-quote. @ inherit from `standard-syntax-table'. | |
| 186 | |
| 187 Only single-character comment start and end sequences are represented thus. | |
| 188 Two-character sequences are represented as described below. | |
| 189 The second character of SPEC is the matching parenthesis, | |
| 190 used only if the first character is `(' or `)'. | |
| 191 Any additional characters are flags. | |
| 192 Defined flags are the characters 1, 2, 3, 4, 5, 6, 7, 8, p, a, and b. | |
| 193 1 means C is the first of a two-char comment start sequence of style a. | |
| 194 2 means C is the second character of such a sequence. | |
| 195 3 means C is the first of a two-char comment end sequence of style a. | |
| 196 4 means C is the second character of such a sequence. | |
| 197 5 means C is the first of a two-char comment start sequence of style b. | |
| 198 6 means C is the second character of such a sequence. | |
| 199 7 means C is the first of a two-char comment end sequence of style b. | |
| 200 8 means C is the second character of such a sequence. | |
| 201 p means C is a prefix character for `backward-prefix-chars'; | |
| 202 such characters are treated as whitespace when they occur | |
| 203 between expressions. | |
| 204 a means C is comment starter or comment ender for comment style a (default) | |
| 205 b means C is comment starter or comment ender for comment style b." | |
| 444 | 206 (interactive |
| 428 | 207 ;; I really don't know why this is interactive |
| 208 ;; help-form should at least be made useful while reading the second arg | |
| 209 "cSet syntax for character: \nsSet syntax for %c to: ") | |
| 444 | 210 (simple-set-syntax-entry |
| 211 char-range | |
| 212 (syntax-string-to-code spec) | |
| 213 (cond ((syntax-table-p syntax-table) | |
| 214 syntax-table) | |
| 215 ((null syntax-table) | |
| 216 (syntax-table)) | |
| 217 (t | |
| 218 (wrong-type-argument 'syntax-table-p syntax-table)))) | |
| 428 | 219 nil) |
| 220 | |
|
4806
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
221 ((macro |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
222 . (lambda (map-syntax-definition) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
223 "Replace the variable names in MAP-SYNTAX-DEFINITION with uninterned |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
224 symbols, at byte-compile time. This avoids the risk of variable names |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
225 within the functions called from MAP-SYNTAX-DEFINITION being shared with |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
226 MAP-SYNTAX-DEFINITION, and as such subject to modification, one of the |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
227 common downsides of dynamic scope." |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
228 (nsublis |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
229 '((syntax-table . #:syntax-table) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
230 (m-s-function . #:function) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
231 (range . #:range) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
232 (key . #:key) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
233 (value . #:value)) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
234 map-syntax-definition))) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
235 (defun map-syntax-table (m-s-function syntax-table &optional range) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
236 "Map FUNCTION over entries in SYNTAX-TABLE, collapsing inheritance. |
| 428 | 237 This is similar to `map-char-table', but works only on syntax tables, and |
| 238 collapses any entries that call for inheritance by invisibly substituting | |
| 239 the inherited values from the standard syntax table." | |
|
4806
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
240 (check-argument-type 'syntax-table-p syntax-table) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
241 (map-char-table #'(lambda (key value) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
242 (if (eq ?@ (char-syntax-from-code value)) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
243 (map-char-table |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
244 #'(lambda (key value) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
245 (funcall m-s-function key value)) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
246 (standard-syntax-table) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
247 key) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
248 (funcall m-s-function key value))) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
249 syntax-table range))) |
| 428 | 250 |
| 251 ;(defun test-xm () | |
| 252 ; (let ((o (copy-syntax-table)) | |
| 253 ; (n (copy-syntax-table)) | |
| 254 ; (codes (syntax-designator-chars)) | |
| 255 ; (flags "12345678abp")) | |
| 256 ; (while t | |
| 257 ; (let ((spec (concat (char-to-string (elt codes | |
| 258 ; (random (length codes)))))) | |
| 259 ; (if (= (random 4) 0) | |
| 260 ; "b" | |
| 261 ; " ") | |
| 262 ; (let* ((n (random 4)) | |
| 263 ; (s (make-string n 0))) | |
| 264 ; (while (> n 0) | |
| 265 ; (setq n (1- n)) | |
| 266 ; (aset s n (aref flags (random (length flags))))) | |
| 267 ; s)))) | |
| 268 ; (message "%S..." spec) | |
| 269 ; (modify-syntax-entry ?a spec o) | |
| 270 ; (xmodify-syntax-entry ?a spec n) | |
| 271 ; (or (= (aref o ?a) (aref n ?a)) | |
| 272 ; (error "%s" | |
| 273 ; (format "fucked with %S: %x %x" | |
| 274 ; spec (aref o ?a) (aref n ?a)))))))) | |
| 275 | |
| 276 | |
| 3067 | 277 (defun describe-char-table (table mapper describe-value stream) |
| 278 "Describe char-table TABLE, outputting to STREAM. | |
| 279 MAPPER maps over the table and should be `map-char-table' or | |
| 280 `map-syntax-table'. DESCRIBE-VALUE is a function of two arguments, | |
| 281 VALUE and STREAM, and should output a description of VALUE." | |
| 428 | 282 (let (first-char |
| 283 last-char | |
| 284 prev-val | |
| 285 (describe-one | |
| 286 (if (featurep 'mule) | |
| 287 #'(lambda (first last value stream) | |
| 288 (if (equal first last) | |
| 289 (cond ((vectorp first) | |
| 290 (princ (format "%s, row %d\t" | |
| 502 | 291 (declare-fboundp (charset-name |
| 292 (aref first 0))) | |
| 428 | 293 (aref first 1)) |
| 294 stream)) | |
| 295 ((symbolp first) | |
| 296 (princ first stream) | |
| 297 (princ "\t" stream)) | |
| 298 (t | |
| 299 (princ (text-char-description first) stream) | |
| 300 (princ "\t" stream))) | |
| 301 (cond ((vectorp first) | |
| 302 (princ (format "%s, rows %d .. %d\t" | |
| 502 | 303 (declare-fboundp (charset-name |
| 304 (aref first 0))) | |
| 428 | 305 (aref first 1) |
| 306 (aref last 1)) | |
| 307 stream)) | |
| 308 ((symbolp first) | |
| 309 (princ (format "%s .. %s\t" first last) stream)) | |
| 310 (t | |
| 311 (princ (format "%s .. %s\t" | |
| 312 (text-char-description first) | |
| 313 (text-char-description last)) | |
| 314 stream)))) | |
| 3067 | 315 (funcall describe-value value stream)) |
| 428 | 316 #'(lambda (first last value stream) |
| 317 (let* ((tem (text-char-description first)) | |
| 318 (pos (length tem)) | |
| 319 ;;(limit (cond ((numberp ctl-arrow) ctl-arrow) | |
| 320 ;; ((memq ctl-arrow '(t nil)) 256) | |
| 321 ;; (t 160))) | |
| 322 ) | |
| 323 (princ tem stream) | |
| 324 (if (> last first) | |
| 325 (progn | |
| 326 (princ " .. " stream) | |
| 327 (setq tem (text-char-description last)) | |
| 328 (princ tem stream) | |
| 329 (setq pos (+ pos (length tem) 4)))) | |
| 330 (while (progn (write-char ?\ stream) | |
| 331 (setq pos (1+ pos)) | |
| 332 (< pos 16)))) | |
| 3067 | 333 (funcall describe-value value stream))))) |
| 334 (funcall mapper | |
| 428 | 335 #'(lambda (range value) |
| 336 (cond | |
| 337 ((not first-char) | |
| 338 (setq first-char range | |
| 339 last-char range | |
| 340 prev-val value)) | |
| 341 ((and (equal value prev-val) | |
| 342 (or | |
| 343 (and (characterp range) | |
| 344 (characterp first-char) | |
| 345 (or (not (featurep 'mule)) | |
| 502 | 346 (eq (declare-fboundp (char-charset range)) |
| 347 (declare-fboundp (char-charset first-char)))) | |
| 428 | 348 (= (char-int last-char) (1- (char-int range)))) |
| 349 (and (vectorp range) | |
| 350 (vectorp first-char) | |
| 351 (eq (aref range 0) (aref first-char 0)) | |
| 352 (= (aref last-char 1) (1- (aref range 1)))))) | |
| 353 (setq last-char range)) | |
| 354 (t | |
| 355 (funcall describe-one first-char last-char prev-val stream) | |
| 356 (setq first-char range | |
| 357 last-char range | |
| 358 prev-val value))) | |
| 359 nil) | |
| 360 table) | |
| 361 (if first-char | |
| 362 (funcall describe-one first-char last-char prev-val stream)))) | |
| 363 | |
| 3067 | 364 (defun describe-syntax-table (table stream) |
| 365 "Output a description of TABLE (a syntax table) to STREAM." | |
| 366 (describe-char-table table 'map-syntax-table 'describe-syntax-code stream)) | |
| 367 | |
| 428 | 368 (defun describe-syntax-code (code stream) |
| 369 (let ((match (and (consp code) (cdr code))) | |
| 370 (invalid (gettext "**invalid**")) ;(empty "") ;constants | |
| 371 (standard-output (or stream standard-output)) | |
| 372 ;; #### I18N3 should temporarily set buffer to output-translatable | |
| 373 (in #'(lambda (string) | |
| 374 (princ ",\n\t\t\t\t ") | |
| 375 (princ string))) | |
| 376 (syntax-string (syntax-code-to-string code))) | |
| 377 (if (consp code) | |
| 378 (setq code (car code))) | |
| 379 (if (null syntax-string) | |
| 380 (princ invalid) | |
| 381 (princ syntax-string) | |
| 382 (princ "\tmeaning: ") | |
| 383 (princ (aref ["whitespace" "punctuation" "word-constituent" | |
| 384 "symbol-constituent" "open-paren" "close-paren" | |
| 385 "expression-prefix" "string-quote" "paired-delimiter" | |
| 386 "escape" "character-quote" "comment-begin" "comment-end" | |
| 387 "inherit" "extended-word-constituent"] | |
| 388 (logand code 127))) | |
| 389 | |
| 390 (if match | |
| 391 (progn | |
| 392 (princ ", matches ") | |
| 393 (princ (text-char-description match)))) | |
| 394 (let* ((spec (elt syntax-string 0)) | |
| 395 (b3 (lsh code -16)) | |
| 396 (start1 (/= 0 (logand b3 128))) ;logtest! | |
| 397 (start1b (/= 0 (logand b3 64))) | |
| 398 (start2 (/= 0 (logand b3 32))) | |
| 399 (start2b (/= 0 (logand b3 16))) | |
| 400 (end1 (/= 0 (logand b3 8))) | |
| 401 (end1b (/= 0 (logand b3 4))) | |
| 402 (end2 (/= 0 (logand b3 2))) | |
| 403 (end2b (/= 0 (logand b3 1))) | |
| 404 (prefix (/= 0 (logand code 128))) | |
| 405 (single-char-p (or (= spec ?<) (= spec ?>)))) | |
| 406 (if start1 | |
| 407 (if single-char-p | |
| 408 (princ ", style A") | |
| 409 (funcall in | |
| 410 (gettext "first character of comment-start sequence A")))) | |
| 411 (if start2 | |
| 412 (funcall in | |
| 413 (gettext "second character of comment-start sequence A"))) | |
| 414 (if end1 | |
| 415 (if single-char-p | |
| 416 (princ ", style A") | |
| 417 (funcall in | |
| 418 (gettext "first character of comment-end sequence A")))) | |
| 419 (if end2 | |
| 420 (funcall in | |
| 421 (gettext "second character of comment-end sequence A"))) | |
| 422 (if start1b | |
| 423 (if single-char-p | |
| 424 (princ ", style B") | |
| 425 (funcall in | |
| 426 (gettext "first character of comment-start sequence B")))) | |
| 427 (if start2b | |
| 428 (funcall in | |
| 429 (gettext "second character of comment-start sequence B"))) | |
| 430 (if end1b | |
| 431 (if single-char-p | |
| 432 (princ ", style B") | |
| 433 (funcall in | |
| 434 (gettext "first character of comment-end sequence B")))) | |
| 435 (if end2b | |
| 436 (funcall in | |
| 437 (gettext "second character of comment-end sequence B"))) | |
| 438 (if prefix | |
| 439 (funcall in | |
| 440 (gettext "prefix character for `backward-prefix-chars'")))) | |
| 441 (terpri stream)))) | |
| 442 | |
| 443 (defun symbol-near-point () | |
| 444 "Return the first textual item to the nearest point." | |
| 445 (interactive) | |
| 446 ;alg stolen from etag.el | |
| 447 (save-excursion | |
| 448 (if (or (bobp) (not (memq (char-syntax (char-before)) '(?w ?_)))) | |
| 449 (while (not (looking-at "\\sw\\|\\s_\\|\\'")) | |
| 450 (forward-char 1))) | |
| 451 (while (looking-at "\\sw\\|\\s_") | |
| 452 (forward-char 1)) | |
| 453 (if (re-search-backward "\\sw\\|\\s_" nil t) | |
| 454 (regexp-quote | |
| 455 (progn (forward-char 1) | |
| 456 (buffer-substring (point) | |
| 457 (progn (forward-sexp -1) | |
| 458 (while (looking-at "\\s'") | |
| 459 (forward-char 1)) | |
| 460 (point))))) | |
| 461 nil))) | |
| 462 | |
| 463 ;;; syntax.el ends here |