Mercurial > hg > xemacs-beta
annotate lisp/syntax.el @ 5247:02d875ebd1ea
Make Lisp reader errors more informative with over-long hex, octal characters
src/ChangeLog addition:
2010-08-21 Aidan Kehoe <kehoea@parhasard.net>
* lread.c (read_escape):
Make error messages better reflect the text that was encountered,
when overlong hex character escapes or non-Latin-1 octal character
escapes are encountered.
man/ChangeLog addition:
2010-08-21 Aidan Kehoe <kehoea@parhasard.net>
* lispref/objects.texi (Character Type):
Go into more detail here on the specific type of error provoked on
overlong hex character escapes and non-Latin-1 octal character
escapes; give details of why the latter may be encountered, and
what to do with such code.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Sat, 21 Aug 2010 19:02:44 +0100 |
| 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 |