Mercurial > hg > xemacs-beta
annotate lisp/syntax.el @ 5577:0b6e7ae1e78f
Update a comment with a better understanding of the optimizer, bytecomp.el
lisp/ChangeLog addition:
2011-10-04 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el (byte-compile-funcall):
Correct a comment here, explaining why the optimizer doesn't
expand (funcall #'(lambda ...)) in some contexts with inline
labels, and why it's reasonable to do it here.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Tue, 04 Oct 2011 09:02:14 +0100 |
| parents | 308d34e9f07d |
| children |
| 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 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4945
diff
changeset
|
9 ;; XEmacs is free software: you can redistribute it and/or modify it |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4945
diff
changeset
|
10 ;; under the terms of the GNU General Public License as published by the |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4945
diff
changeset
|
11 ;; Free Software Foundation, either version 3 of the License, or (at your |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4945
diff
changeset
|
12 ;; option) any later version. |
| 428 | 13 |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4945
diff
changeset
|
14 ;; XEmacs is distributed in the hope that it will be useful, but WITHOUT |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4945
diff
changeset
|
15 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4945
diff
changeset
|
16 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4945
diff
changeset
|
17 ;; for more details. |
| 428 | 18 |
| 19 ;; You should have received a copy of the GNU General Public License | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
4945
diff
changeset
|
20 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>. |
| 428 | 21 |
| 22 ;;; Synched up with: FSF 19.28. | |
| 23 | |
| 24 ;;; Commentary: | |
| 25 | |
| 26 ;; This file is dumped with XEmacs. | |
| 27 | |
| 28 ;; Note: FSF does not have a file syntax.el. This stuff is | |
| 29 ;; in syntax.c. See comments there about not merging past 19.28. | |
| 30 | |
| 31 ;; Significantly hacked upon by Ben Wing. | |
| 32 | |
| 33 ;;; Code: | |
| 34 | |
| 35 (defun make-syntax-table (&optional oldtable) | |
| 36 "Return a new syntax table. | |
|
4945
99e465e2da2e
(main branch) Update make-syntax-table doc
Ben Wing <ben@xemacs.org>
parents:
4806
diff
changeset
|
37 |
|
99e465e2da2e
(main branch) Update make-syntax-table doc
Ben Wing <ben@xemacs.org>
parents:
4806
diff
changeset
|
38 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
|
39 |
|
99e465e2da2e
(main branch) Update make-syntax-table doc
Ben Wing <ben@xemacs.org>
parents:
4806
diff
changeset
|
40 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
|
41 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
|
42 `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
|
43 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
|
44 for `inherit'.) |
|
99e465e2da2e
(main branch) Update make-syntax-table doc
Ben Wing <ben@xemacs.org>
parents:
4806
diff
changeset
|
45 |
|
99e465e2da2e
(main branch) Update make-syntax-table doc
Ben Wing <ben@xemacs.org>
parents:
4806
diff
changeset
|
46 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
|
47 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
|
48 |
|
99e465e2da2e
(main branch) Update make-syntax-table doc
Ben Wing <ben@xemacs.org>
parents:
4806
diff
changeset
|
49 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
|
50 to indicate the various syntax classes." |
| 428 | 51 (make-char-table 'syntax)) |
| 52 | |
|
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
|
53 (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
|
54 "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
|
55 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
|
56 (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
|
57 (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
|
58 (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
|
59 (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
|
60 |
| 428 | 61 (defun simple-set-syntax-entry (char spec table) |
| 62 (put-char-table char spec table)) | |
| 63 | |
| 64 (defun char-syntax-from-code (code) | |
| 65 "Extract the syntax designator from the internal syntax code CODE. | |
| 66 CODE is the value actually contained in the syntax table." | |
| 67 (if (consp code) | |
| 68 (setq code (car code))) | |
| 69 (aref (syntax-designator-chars) (logand code 127))) | |
| 70 | |
| 71 (defun set-char-syntax-in-code (code desig) | |
| 72 "Return a new internal syntax code whose syntax designator is DESIG. | |
| 73 Other characteristics are the same as in CODE." | |
| 74 (let ((newcode (if (consp code) (car code) code))) | |
| 75 (setq newcode (logior (string-match | |
| 76 (regexp-quote (char-to-string desig)) | |
| 77 (syntax-designator-chars)) | |
| 78 (logand newcode (lognot 127)))) | |
| 79 (if (consp code) (cons newcode (cdr code)) | |
| 80 newcode))) | |
| 81 | |
| 82 (defun syntax-code-to-string (code) | |
| 83 "Return a string equivalent to internal syntax code CODE. | |
| 84 The string can be passed to `modify-syntax-entry'. | |
| 85 If CODE is invalid, return nil." | |
| 86 (let ((match (and (consp code) (cdr code))) | |
| 87 (codes (syntax-designator-chars))) | |
| 88 (if (consp code) | |
| 89 (setq code (car code))) | |
| 90 (if (or (not (integerp code)) | |
| 91 (> (logand code 127) (length codes))) | |
| 92 nil | |
| 93 (with-output-to-string | |
| 94 (let* ((spec (elt codes (logand code 127))) | |
| 95 (b3 (lsh code -16)) | |
| 96 (start1 (/= 0 (logand b3 128))) ;logtest! | |
| 97 (start1b (/= 0 (logand b3 64))) | |
| 98 (start2 (/= 0 (logand b3 32))) | |
| 99 (start2b (/= 0 (logand b3 16))) | |
| 100 (end1 (/= 0 (logand b3 8))) | |
| 101 (end1b (/= 0 (logand b3 4))) | |
| 102 (end2 (/= 0 (logand b3 2))) | |
| 103 (end2b (/= 0 (logand b3 1))) | |
| 104 (prefix (/= 0 (logand code 128))) | |
| 105 (single-char-p (or (= spec ?<) (= spec ?>))) | |
| 106 ) | |
| 107 (write-char spec) | |
| 108 (write-char (if match match 32)) | |
| 109 ;;; (if start1 (if single-char-p (write-char ?a) (write-char ?1))) | |
| 110 (if start1 (if single-char-p (write-char ? ) (write-char ?1))) | |
| 111 (if start2 (write-char ?2)) | |
| 112 ;;; (if end1 (if single-char-p (write-char ?a) (write-char ?3))) | |
| 113 (if end1 (if single-char-p (write-char ? ) (write-char ?3))) | |
| 114 (if end2 (write-char ?4)) | |
| 115 (if start1b (if single-char-p (write-char ?b) (write-char ?5))) | |
| 116 (if start2b (write-char ?6)) | |
| 117 (if end1b (if single-char-p (write-char ?b) (write-char ?7))) | |
| 118 (if end2b (write-char ?8)) | |
| 119 (if prefix (write-char ?p))))))) | |
| 120 | |
| 121 (defun syntax-string-to-code (string) | |
| 122 "Return the internal syntax code equivalent to STRING. | |
| 123 STRING should be something acceptable as the second argument to | |
| 124 `modify-syntax-entry'. | |
| 125 If STRING is invalid, signal an error." | |
| 126 (let* ((bflag nil) | |
| 127 (b3 0) | |
| 128 (ch0 (aref string 0)) | |
| 129 (len (length string)) | |
| 130 (code (string-match (regexp-quote (char-to-string ch0)) | |
| 131 (syntax-designator-chars))) | |
| 132 (i 2) | |
| 133 ch) | |
| 134 (or code | |
| 135 (error "Invalid syntax designator: %S" string)) | |
| 136 (while (< i len) | |
| 137 (setq ch (aref string i)) | |
| 138 (incf i) | |
| 139 (case ch | |
| 140 (?1 (setq b3 (logior b3 128))) | |
| 141 (?2 (setq b3 (logior b3 32))) | |
| 142 (?3 (setq b3 (logior b3 8))) | |
| 143 (?4 (setq b3 (logior b3 2))) | |
| 144 (?5 (setq b3 (logior b3 64))) | |
| 145 (?6 (setq b3 (logior b3 16))) | |
| 146 (?7 (setq b3 (logior b3 4))) | |
| 147 (?8 (setq b3 (logior b3 1))) | |
| 148 (?a (case ch0 | |
| 149 (?< (setq b3 (logior b3 128))) | |
| 150 (?> (setq b3 (logior b3 8))))) | |
| 151 (?b (case ch0 | |
| 152 (?< (setq b3 (logior b3 64) bflag t)) | |
| 153 (?> (setq b3 (logior b3 4) bflag t)))) | |
| 154 (?p (setq code (logior code (lsh 1 7)))) | |
| 155 (?\ nil) ;; ignore for compatibility | |
| 156 (otherwise | |
| 157 (error "Invalid syntax description flag: %S" string)))) | |
| 158 ;; default single char style if `b' has not been seen | |
| 159 (if (not bflag) | |
| 160 (case ch0 | |
| 161 (?< (setq b3 (logior b3 128))) | |
| 162 (?> (setq b3 (logior b3 8))))) | |
| 163 (setq code (logior code (lsh b3 16))) | |
| 164 (if (and (> len 1) | |
| 165 ;; tough luck if you want to make space a paren! | |
| 166 (/= (aref string 1) ?\ )) | |
| 167 (setq code (cons code (aref string 1)))) | |
| 168 code)) | |
| 169 | |
| 444 | 170 (defun modify-syntax-entry (char-range spec &optional syntax-table) |
| 428 | 171 "Set syntax for the characters CHAR-RANGE according to string SPEC. |
| 172 CHAR-RANGE is a single character or a range of characters, | |
| 173 as per `put-char-table'. | |
| 444 | 174 The syntax is changed only for SYNTAX-TABLE, which defaults to |
| 428 | 175 the current buffer's syntax table. |
| 176 The first character of SPEC should be one of the following: | |
| 177 Space whitespace syntax. w word constituent. | |
| 178 _ symbol constituent. . punctuation. | |
| 179 \( open-parenthesis. \) close-parenthesis. | |
| 180 \" string quote. \\ character-quote. | |
| 181 $ paired delimiter. ' expression quote or prefix operator. | |
| 182 < comment starter. > comment ender. | |
| 183 / character-quote. @ inherit from `standard-syntax-table'. | |
| 184 | |
| 185 Only single-character comment start and end sequences are represented thus. | |
| 186 Two-character sequences are represented as described below. | |
| 187 The second character of SPEC is the matching parenthesis, | |
| 188 used only if the first character is `(' or `)'. | |
| 189 Any additional characters are flags. | |
| 190 Defined flags are the characters 1, 2, 3, 4, 5, 6, 7, 8, p, a, and b. | |
| 191 1 means C is the first of a two-char comment start sequence of style a. | |
| 192 2 means C is the second character of such a sequence. | |
| 193 3 means C is the first of a two-char comment end sequence of style a. | |
| 194 4 means C is the second character of such a sequence. | |
| 195 5 means C is the first of a two-char comment start sequence of style b. | |
| 196 6 means C is the second character of such a sequence. | |
| 197 7 means C is the first of a two-char comment end sequence of style b. | |
| 198 8 means C is the second character of such a sequence. | |
| 199 p means C is a prefix character for `backward-prefix-chars'; | |
| 200 such characters are treated as whitespace when they occur | |
| 201 between expressions. | |
| 202 a means C is comment starter or comment ender for comment style a (default) | |
| 203 b means C is comment starter or comment ender for comment style b." | |
| 444 | 204 (interactive |
| 428 | 205 ;; I really don't know why this is interactive |
| 206 ;; help-form should at least be made useful while reading the second arg | |
| 207 "cSet syntax for character: \nsSet syntax for %c to: ") | |
| 444 | 208 (simple-set-syntax-entry |
| 209 char-range | |
| 210 (syntax-string-to-code spec) | |
| 211 (cond ((syntax-table-p syntax-table) | |
| 212 syntax-table) | |
| 213 ((null syntax-table) | |
| 214 (syntax-table)) | |
| 215 (t | |
| 216 (wrong-type-argument 'syntax-table-p syntax-table)))) | |
| 428 | 217 nil) |
| 218 | |
|
4806
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
219 ((macro |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
220 . (lambda (map-syntax-definition) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
221 "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
|
222 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
|
223 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
|
224 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
|
225 common downsides of dynamic scope." |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
226 (nsublis |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
227 '((syntax-table . #:syntax-table) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
228 (m-s-function . #:function) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
229 (range . #:range) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
230 (key . #:key) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
231 (value . #:value)) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
232 map-syntax-definition))) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
233 (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
|
234 "Map FUNCTION over entries in SYNTAX-TABLE, collapsing inheritance. |
| 428 | 235 This is similar to `map-char-table', but works only on syntax tables, and |
| 236 collapses any entries that call for inheritance by invisibly substituting | |
| 237 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
|
238 (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
|
239 (map-char-table #'(lambda (key value) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
240 (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
|
241 (map-char-table |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
242 #'(lambda (key value) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
243 (funcall m-s-function key value)) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
244 (standard-syntax-table) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
245 key) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
246 (funcall m-s-function key value))) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4468
diff
changeset
|
247 syntax-table range))) |
| 428 | 248 |
| 249 ;(defun test-xm () | |
| 250 ; (let ((o (copy-syntax-table)) | |
| 251 ; (n (copy-syntax-table)) | |
| 252 ; (codes (syntax-designator-chars)) | |
| 253 ; (flags "12345678abp")) | |
| 254 ; (while t | |
| 255 ; (let ((spec (concat (char-to-string (elt codes | |
| 256 ; (random (length codes)))))) | |
| 257 ; (if (= (random 4) 0) | |
| 258 ; "b" | |
| 259 ; " ") | |
| 260 ; (let* ((n (random 4)) | |
| 261 ; (s (make-string n 0))) | |
| 262 ; (while (> n 0) | |
| 263 ; (setq n (1- n)) | |
| 264 ; (aset s n (aref flags (random (length flags))))) | |
| 265 ; s)))) | |
| 266 ; (message "%S..." spec) | |
| 267 ; (modify-syntax-entry ?a spec o) | |
| 268 ; (xmodify-syntax-entry ?a spec n) | |
| 269 ; (or (= (aref o ?a) (aref n ?a)) | |
| 270 ; (error "%s" | |
| 271 ; (format "fucked with %S: %x %x" | |
| 272 ; spec (aref o ?a) (aref n ?a)))))))) | |
| 273 | |
| 274 | |
| 3067 | 275 (defun describe-char-table (table mapper describe-value stream) |
| 276 "Describe char-table TABLE, outputting to STREAM. | |
| 277 MAPPER maps over the table and should be `map-char-table' or | |
| 278 `map-syntax-table'. DESCRIBE-VALUE is a function of two arguments, | |
| 279 VALUE and STREAM, and should output a description of VALUE." | |
| 428 | 280 (let (first-char |
| 281 last-char | |
| 282 prev-val | |
| 283 (describe-one | |
| 284 (if (featurep 'mule) | |
| 285 #'(lambda (first last value stream) | |
| 286 (if (equal first last) | |
| 287 (cond ((vectorp first) | |
| 288 (princ (format "%s, row %d\t" | |
| 502 | 289 (declare-fboundp (charset-name |
| 290 (aref first 0))) | |
| 428 | 291 (aref first 1)) |
| 292 stream)) | |
| 293 ((symbolp first) | |
| 294 (princ first stream) | |
| 295 (princ "\t" stream)) | |
| 296 (t | |
| 297 (princ (text-char-description first) stream) | |
| 298 (princ "\t" stream))) | |
| 299 (cond ((vectorp first) | |
| 300 (princ (format "%s, rows %d .. %d\t" | |
| 502 | 301 (declare-fboundp (charset-name |
| 302 (aref first 0))) | |
| 428 | 303 (aref first 1) |
| 304 (aref last 1)) | |
| 305 stream)) | |
| 306 ((symbolp first) | |
| 307 (princ (format "%s .. %s\t" first last) stream)) | |
| 308 (t | |
| 309 (princ (format "%s .. %s\t" | |
| 310 (text-char-description first) | |
| 311 (text-char-description last)) | |
| 312 stream)))) | |
| 3067 | 313 (funcall describe-value value stream)) |
| 428 | 314 #'(lambda (first last value stream) |
| 315 (let* ((tem (text-char-description first)) | |
| 316 (pos (length tem)) | |
| 317 ;;(limit (cond ((numberp ctl-arrow) ctl-arrow) | |
| 318 ;; ((memq ctl-arrow '(t nil)) 256) | |
| 319 ;; (t 160))) | |
| 320 ) | |
| 321 (princ tem stream) | |
| 322 (if (> last first) | |
| 323 (progn | |
| 324 (princ " .. " stream) | |
| 325 (setq tem (text-char-description last)) | |
| 326 (princ tem stream) | |
| 327 (setq pos (+ pos (length tem) 4)))) | |
| 328 (while (progn (write-char ?\ stream) | |
| 329 (setq pos (1+ pos)) | |
| 330 (< pos 16)))) | |
| 3067 | 331 (funcall describe-value value stream))))) |
| 332 (funcall mapper | |
| 428 | 333 #'(lambda (range value) |
| 334 (cond | |
| 335 ((not first-char) | |
| 336 (setq first-char range | |
| 337 last-char range | |
| 338 prev-val value)) | |
| 339 ((and (equal value prev-val) | |
| 340 (or | |
| 341 (and (characterp range) | |
| 342 (characterp first-char) | |
| 343 (or (not (featurep 'mule)) | |
| 502 | 344 (eq (declare-fboundp (char-charset range)) |
| 345 (declare-fboundp (char-charset first-char)))) | |
| 428 | 346 (= (char-int last-char) (1- (char-int range)))) |
| 347 (and (vectorp range) | |
| 348 (vectorp first-char) | |
| 349 (eq (aref range 0) (aref first-char 0)) | |
| 350 (= (aref last-char 1) (1- (aref range 1)))))) | |
| 351 (setq last-char range)) | |
| 352 (t | |
| 353 (funcall describe-one first-char last-char prev-val stream) | |
| 354 (setq first-char range | |
| 355 last-char range | |
| 356 prev-val value))) | |
| 357 nil) | |
| 358 table) | |
| 359 (if first-char | |
| 360 (funcall describe-one first-char last-char prev-val stream)))) | |
| 361 | |
| 3067 | 362 (defun describe-syntax-table (table stream) |
| 363 "Output a description of TABLE (a syntax table) to STREAM." | |
| 364 (describe-char-table table 'map-syntax-table 'describe-syntax-code stream)) | |
| 365 | |
| 428 | 366 (defun describe-syntax-code (code stream) |
| 367 (let ((match (and (consp code) (cdr code))) | |
| 368 (invalid (gettext "**invalid**")) ;(empty "") ;constants | |
| 369 (standard-output (or stream standard-output)) | |
| 370 ;; #### I18N3 should temporarily set buffer to output-translatable | |
| 371 (in #'(lambda (string) | |
| 372 (princ ",\n\t\t\t\t ") | |
| 373 (princ string))) | |
| 374 (syntax-string (syntax-code-to-string code))) | |
| 375 (if (consp code) | |
| 376 (setq code (car code))) | |
| 377 (if (null syntax-string) | |
| 378 (princ invalid) | |
| 379 (princ syntax-string) | |
| 380 (princ "\tmeaning: ") | |
| 381 (princ (aref ["whitespace" "punctuation" "word-constituent" | |
| 382 "symbol-constituent" "open-paren" "close-paren" | |
| 383 "expression-prefix" "string-quote" "paired-delimiter" | |
| 384 "escape" "character-quote" "comment-begin" "comment-end" | |
| 385 "inherit" "extended-word-constituent"] | |
| 386 (logand code 127))) | |
| 387 | |
| 388 (if match | |
| 389 (progn | |
| 390 (princ ", matches ") | |
| 391 (princ (text-char-description match)))) | |
| 392 (let* ((spec (elt syntax-string 0)) | |
| 393 (b3 (lsh code -16)) | |
| 394 (start1 (/= 0 (logand b3 128))) ;logtest! | |
| 395 (start1b (/= 0 (logand b3 64))) | |
| 396 (start2 (/= 0 (logand b3 32))) | |
| 397 (start2b (/= 0 (logand b3 16))) | |
| 398 (end1 (/= 0 (logand b3 8))) | |
| 399 (end1b (/= 0 (logand b3 4))) | |
| 400 (end2 (/= 0 (logand b3 2))) | |
| 401 (end2b (/= 0 (logand b3 1))) | |
| 402 (prefix (/= 0 (logand code 128))) | |
| 403 (single-char-p (or (= spec ?<) (= spec ?>)))) | |
| 404 (if start1 | |
| 405 (if single-char-p | |
| 406 (princ ", style A") | |
| 407 (funcall in | |
| 408 (gettext "first character of comment-start sequence A")))) | |
| 409 (if start2 | |
| 410 (funcall in | |
| 411 (gettext "second character of comment-start sequence A"))) | |
| 412 (if end1 | |
| 413 (if single-char-p | |
| 414 (princ ", style A") | |
| 415 (funcall in | |
| 416 (gettext "first character of comment-end sequence A")))) | |
| 417 (if end2 | |
| 418 (funcall in | |
| 419 (gettext "second character of comment-end sequence A"))) | |
| 420 (if start1b | |
| 421 (if single-char-p | |
| 422 (princ ", style B") | |
| 423 (funcall in | |
| 424 (gettext "first character of comment-start sequence B")))) | |
| 425 (if start2b | |
| 426 (funcall in | |
| 427 (gettext "second character of comment-start sequence B"))) | |
| 428 (if end1b | |
| 429 (if single-char-p | |
| 430 (princ ", style B") | |
| 431 (funcall in | |
| 432 (gettext "first character of comment-end sequence B")))) | |
| 433 (if end2b | |
| 434 (funcall in | |
| 435 (gettext "second character of comment-end sequence B"))) | |
| 436 (if prefix | |
| 437 (funcall in | |
| 438 (gettext "prefix character for `backward-prefix-chars'")))) | |
| 439 (terpri stream)))) | |
| 440 | |
| 441 (defun symbol-near-point () | |
| 442 "Return the first textual item to the nearest point." | |
| 443 (interactive) | |
| 444 ;alg stolen from etag.el | |
| 445 (save-excursion | |
| 446 (if (or (bobp) (not (memq (char-syntax (char-before)) '(?w ?_)))) | |
| 447 (while (not (looking-at "\\sw\\|\\s_\\|\\'")) | |
| 448 (forward-char 1))) | |
| 449 (while (looking-at "\\sw\\|\\s_") | |
| 450 (forward-char 1)) | |
| 451 (if (re-search-backward "\\sw\\|\\s_" nil t) | |
| 452 (regexp-quote | |
| 453 (progn (forward-char 1) | |
| 454 (buffer-substring (point) | |
| 455 (progn (forward-sexp -1) | |
| 456 (while (looking-at "\\s'") | |
| 457 (forward-char 1)) | |
| 458 (point))))) | |
| 459 nil))) | |
| 460 | |
| 461 ;;; syntax.el ends here |