Mercurial > hg > xemacs-beta
annotate lisp/syntax.el @ 4520:279cadceaa13
Merge in doc and test changes from September 2008.
| author | Stephen J. Turnbull <stephen@xemacs.org> |
|---|---|
| date | Mon, 27 Oct 2008 09:51:51 +0900 |
| parents | a78d697ccd2c |
| children | fd36a980d701 |
| 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 | |
| 444 | 208 (defun map-syntax-table (__function __syntax_table &optional __range) |
| 209 "Map FUNCTION over entries in SYNTAX-TABLE, collapsing inheritance. | |
| 428 | 210 This is similar to `map-char-table', but works only on syntax tables, and |
| 211 collapses any entries that call for inheritance by invisibly substituting | |
| 212 the inherited values from the standard syntax table." | |
| 444 | 213 (check-argument-type 'syntax-table-p __syntax_table) |
| 428 | 214 (map-char-table #'(lambda (__key __value) |
| 215 (if (eq ?@ (char-syntax-from-code __value)) | |
| 216 (map-char-table #'(lambda (__key __value) | |
| 217 (funcall __function | |
| 218 __key __value)) | |
| 219 (standard-syntax-table) | |
| 220 __key) | |
| 221 (funcall __function __key __value))) | |
| 444 | 222 __syntax_table __range)) |
| 428 | 223 |
| 224 ;(defun test-xm () | |
| 225 ; (let ((o (copy-syntax-table)) | |
| 226 ; (n (copy-syntax-table)) | |
| 227 ; (codes (syntax-designator-chars)) | |
| 228 ; (flags "12345678abp")) | |
| 229 ; (while t | |
| 230 ; (let ((spec (concat (char-to-string (elt codes | |
| 231 ; (random (length codes)))))) | |
| 232 ; (if (= (random 4) 0) | |
| 233 ; "b" | |
| 234 ; " ") | |
| 235 ; (let* ((n (random 4)) | |
| 236 ; (s (make-string n 0))) | |
| 237 ; (while (> n 0) | |
| 238 ; (setq n (1- n)) | |
| 239 ; (aset s n (aref flags (random (length flags))))) | |
| 240 ; s)))) | |
| 241 ; (message "%S..." spec) | |
| 242 ; (modify-syntax-entry ?a spec o) | |
| 243 ; (xmodify-syntax-entry ?a spec n) | |
| 244 ; (or (= (aref o ?a) (aref n ?a)) | |
| 245 ; (error "%s" | |
| 246 ; (format "fucked with %S: %x %x" | |
| 247 ; spec (aref o ?a) (aref n ?a)))))))) | |
| 248 | |
| 249 | |
| 3067 | 250 (defun describe-char-table (table mapper describe-value stream) |
| 251 "Describe char-table TABLE, outputting to STREAM. | |
| 252 MAPPER maps over the table and should be `map-char-table' or | |
| 253 `map-syntax-table'. DESCRIBE-VALUE is a function of two arguments, | |
| 254 VALUE and STREAM, and should output a description of VALUE." | |
| 428 | 255 (let (first-char |
| 256 last-char | |
| 257 prev-val | |
| 258 (describe-one | |
| 259 (if (featurep 'mule) | |
| 260 #'(lambda (first last value stream) | |
| 261 (if (equal first last) | |
| 262 (cond ((vectorp first) | |
| 263 (princ (format "%s, row %d\t" | |
| 502 | 264 (declare-fboundp (charset-name |
| 265 (aref first 0))) | |
| 428 | 266 (aref first 1)) |
| 267 stream)) | |
| 268 ((symbolp first) | |
| 269 (princ first stream) | |
| 270 (princ "\t" stream)) | |
| 271 (t | |
| 272 (princ (text-char-description first) stream) | |
| 273 (princ "\t" stream))) | |
| 274 (cond ((vectorp first) | |
| 275 (princ (format "%s, rows %d .. %d\t" | |
| 502 | 276 (declare-fboundp (charset-name |
| 277 (aref first 0))) | |
| 428 | 278 (aref first 1) |
| 279 (aref last 1)) | |
| 280 stream)) | |
| 281 ((symbolp first) | |
| 282 (princ (format "%s .. %s\t" first last) stream)) | |
| 283 (t | |
| 284 (princ (format "%s .. %s\t" | |
| 285 (text-char-description first) | |
| 286 (text-char-description last)) | |
| 287 stream)))) | |
| 3067 | 288 (funcall describe-value value stream)) |
| 428 | 289 #'(lambda (first last value stream) |
| 290 (let* ((tem (text-char-description first)) | |
| 291 (pos (length tem)) | |
| 292 ;;(limit (cond ((numberp ctl-arrow) ctl-arrow) | |
| 293 ;; ((memq ctl-arrow '(t nil)) 256) | |
| 294 ;; (t 160))) | |
| 295 ) | |
| 296 (princ tem stream) | |
| 297 (if (> last first) | |
| 298 (progn | |
| 299 (princ " .. " stream) | |
| 300 (setq tem (text-char-description last)) | |
| 301 (princ tem stream) | |
| 302 (setq pos (+ pos (length tem) 4)))) | |
| 303 (while (progn (write-char ?\ stream) | |
| 304 (setq pos (1+ pos)) | |
| 305 (< pos 16)))) | |
| 3067 | 306 (funcall describe-value value stream))))) |
| 307 (funcall mapper | |
| 428 | 308 #'(lambda (range value) |
| 309 (cond | |
| 310 ((not first-char) | |
| 311 (setq first-char range | |
| 312 last-char range | |
| 313 prev-val value)) | |
| 314 ((and (equal value prev-val) | |
| 315 (or | |
| 316 (and (characterp range) | |
| 317 (characterp first-char) | |
| 318 (or (not (featurep 'mule)) | |
| 502 | 319 (eq (declare-fboundp (char-charset range)) |
| 320 (declare-fboundp (char-charset first-char)))) | |
| 428 | 321 (= (char-int last-char) (1- (char-int range)))) |
| 322 (and (vectorp range) | |
| 323 (vectorp first-char) | |
| 324 (eq (aref range 0) (aref first-char 0)) | |
| 325 (= (aref last-char 1) (1- (aref range 1)))))) | |
| 326 (setq last-char range)) | |
| 327 (t | |
| 328 (funcall describe-one first-char last-char prev-val stream) | |
| 329 (setq first-char range | |
| 330 last-char range | |
| 331 prev-val value))) | |
| 332 nil) | |
| 333 table) | |
| 334 (if first-char | |
| 335 (funcall describe-one first-char last-char prev-val stream)))) | |
| 336 | |
| 3067 | 337 (defun describe-syntax-table (table stream) |
| 338 "Output a description of TABLE (a syntax table) to STREAM." | |
| 339 (describe-char-table table 'map-syntax-table 'describe-syntax-code stream)) | |
| 340 | |
| 428 | 341 (defun describe-syntax-code (code stream) |
| 342 (let ((match (and (consp code) (cdr code))) | |
| 343 (invalid (gettext "**invalid**")) ;(empty "") ;constants | |
| 344 (standard-output (or stream standard-output)) | |
| 345 ;; #### I18N3 should temporarily set buffer to output-translatable | |
| 346 (in #'(lambda (string) | |
| 347 (princ ",\n\t\t\t\t ") | |
| 348 (princ string))) | |
| 349 (syntax-string (syntax-code-to-string code))) | |
| 350 (if (consp code) | |
| 351 (setq code (car code))) | |
| 352 (if (null syntax-string) | |
| 353 (princ invalid) | |
| 354 (princ syntax-string) | |
| 355 (princ "\tmeaning: ") | |
| 356 (princ (aref ["whitespace" "punctuation" "word-constituent" | |
| 357 "symbol-constituent" "open-paren" "close-paren" | |
| 358 "expression-prefix" "string-quote" "paired-delimiter" | |
| 359 "escape" "character-quote" "comment-begin" "comment-end" | |
| 360 "inherit" "extended-word-constituent"] | |
| 361 (logand code 127))) | |
| 362 | |
| 363 (if match | |
| 364 (progn | |
| 365 (princ ", matches ") | |
| 366 (princ (text-char-description match)))) | |
| 367 (let* ((spec (elt syntax-string 0)) | |
| 368 (b3 (lsh code -16)) | |
| 369 (start1 (/= 0 (logand b3 128))) ;logtest! | |
| 370 (start1b (/= 0 (logand b3 64))) | |
| 371 (start2 (/= 0 (logand b3 32))) | |
| 372 (start2b (/= 0 (logand b3 16))) | |
| 373 (end1 (/= 0 (logand b3 8))) | |
| 374 (end1b (/= 0 (logand b3 4))) | |
| 375 (end2 (/= 0 (logand b3 2))) | |
| 376 (end2b (/= 0 (logand b3 1))) | |
| 377 (prefix (/= 0 (logand code 128))) | |
| 378 (single-char-p (or (= spec ?<) (= spec ?>)))) | |
| 379 (if start1 | |
| 380 (if single-char-p | |
| 381 (princ ", style A") | |
| 382 (funcall in | |
| 383 (gettext "first character of comment-start sequence A")))) | |
| 384 (if start2 | |
| 385 (funcall in | |
| 386 (gettext "second character of comment-start sequence A"))) | |
| 387 (if end1 | |
| 388 (if single-char-p | |
| 389 (princ ", style A") | |
| 390 (funcall in | |
| 391 (gettext "first character of comment-end sequence A")))) | |
| 392 (if end2 | |
| 393 (funcall in | |
| 394 (gettext "second character of comment-end sequence A"))) | |
| 395 (if start1b | |
| 396 (if single-char-p | |
| 397 (princ ", style B") | |
| 398 (funcall in | |
| 399 (gettext "first character of comment-start sequence B")))) | |
| 400 (if start2b | |
| 401 (funcall in | |
| 402 (gettext "second character of comment-start sequence B"))) | |
| 403 (if end1b | |
| 404 (if single-char-p | |
| 405 (princ ", style B") | |
| 406 (funcall in | |
| 407 (gettext "first character of comment-end sequence B")))) | |
| 408 (if end2b | |
| 409 (funcall in | |
| 410 (gettext "second character of comment-end sequence B"))) | |
| 411 (if prefix | |
| 412 (funcall in | |
| 413 (gettext "prefix character for `backward-prefix-chars'")))) | |
| 414 (terpri stream)))) | |
| 415 | |
| 416 (defun symbol-near-point () | |
| 417 "Return the first textual item to the nearest point." | |
| 418 (interactive) | |
| 419 ;alg stolen from etag.el | |
| 420 (save-excursion | |
| 421 (if (or (bobp) (not (memq (char-syntax (char-before)) '(?w ?_)))) | |
| 422 (while (not (looking-at "\\sw\\|\\s_\\|\\'")) | |
| 423 (forward-char 1))) | |
| 424 (while (looking-at "\\sw\\|\\s_") | |
| 425 (forward-char 1)) | |
| 426 (if (re-search-backward "\\sw\\|\\s_" nil t) | |
| 427 (regexp-quote | |
| 428 (progn (forward-char 1) | |
| 429 (buffer-substring (point) | |
| 430 (progn (forward-sexp -1) | |
| 431 (while (looking-at "\\s'") | |
| 432 (forward-char 1)) | |
| 433 (point))))) | |
| 434 nil))) | |
| 435 | |
| 436 ;;; syntax.el ends here |