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