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