Mercurial > hg > xemacs-beta

comparison lisp/prim/syntax.el @ 70:131b0175ea99 r20-0b30

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents 0293115a14e9
children 3bb7ccffb0c0
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
1 ;; Syntax-table hacking stuff, moved from syntax.c 1 ;; Syntax-table hacking stuff, moved from syntax.c
2 ;; Copyright (C) 1993 Free Software Foundation, Inc. 2 ;; Copyright (C) 1993 Free Software Foundation, Inc.
3 ;; Copyright (C) 1995 Sun Microsystems.
3 4
4 ;; This file is part of XEmacs. 5 ;; This file is part of XEmacs.
5 6
6 ;; XEmacs is free software; you can redistribute it and/or modify it 7 ;; XEmacs is free software; you can redistribute it and/or modify it
7 ;; under the terms of the GNU General Public License as published by 8 ;; under the terms of the GNU General Public License as published by
13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;; General Public License for more details. 15 ;; General Public License for more details.
15 16
16 ;; You should have received a copy of the GNU General Public License 17 ;; You should have received a copy of the GNU General Public License
17 ;; along with XEmacs; see the file COPYING. If not, write to the 18 ;; along with XEmacs; see the file COPYING. If not, write to the
18 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 19 ;; Free Software Foundation, 59 Temple Place - Suite 330,
19 ;; Boston, MA 02111-1307, USA. 20 ;; Boston, MA 02111-1307, USA.
20 21
21 ;;; Synched up with: FSF 19.28. 22 ;;; Synched up with: FSF 19.28.
22 ;;; Note: FSF does not have a file syntax.el. This stuff is 23 ;;; Note: FSF does not have a file syntax.el. This stuff is
23 ;;; in syntax.c. See comments there about not merging past 19.28. 24 ;;; in syntax.c. See comments there about not merging past 19.28.
24 25
26 ;; Significantly hacked upon by Ben Wing.
27
25 (defun make-syntax-table (&optional oldtable) 28 (defun make-syntax-table (&optional oldtable)
26 "Return a new syntax table. 29 "Return a new syntax table.
27 It inherits all letters and control characters from the standard 30 It inherits all characters from the standard syntax table."
28 syntax table; other characters are copied from the standard syntax table." 31 (make-char-table 'syntax))
29 (if oldtable 32
30 (copy-syntax-table oldtable) 33 (defun simple-set-syntax-entry (char spec table)
31 (let ((table (copy-syntax-table)) 34 (put-char-table char spec table))
32 i) 35
33 (setq i 0) 36 (defun char-syntax-from-code (code)
34 (while (<= i 31) 37 "Extract the syntax designator from the internal syntax code CODE.
35 (aset table i 13) 38 CODE is the value actually contained in the syntax table."
36 (setq i (1+ i))) 39 (if (consp code)
37 (setq i ?A) 40 (setq code (car code)))
38 (while (<= i ?Z) 41 (aref (syntax-designator-chars) (logand code 127)))
39 (aset table i 13) 42
40 (setq i (1+ i))) 43 (defun set-char-syntax-in-code (code desig)
41 (setq i ?a) 44 "Return a new internal syntax code whose syntax designator is DESIG.
42 (while (<= i ?z) 45 Other characteristics are the same as in CODE."
43 (aset table i 13) 46 (let ((newcode (if (consp code) (car code) code)))
44 (setq i (1+ i))) 47 (setq newcode (logior (string-match
45 (setq i 128) 48 (regexp-quote (char-to-string desig))
46 (while (<= i 255) 49 (syntax-designator-chars))
47 (aset table i 13) 50 (logand newcode (lognot 127))))
48 (setq i (1+ i))) 51 (if (consp code) (cons newcode (cdr code))
49 table))) 52 newcode)))
50 53
51 (defun modify-syntax-entry (char spec &optional table) 54 (defun syntax-code-to-string (code)
52 "Set syntax for character CHAR according to string S. 55 "Return a string equivalent to internal syntax code CODE.
56 The string can be passed to `modify-syntax-entry'.
57 If CODE is invalid, return nil."
58 (let ((match (and (consp code) (cdr code)))
59 (codes (syntax-designator-chars)))
60 (if (consp code)
61 (setq code (car code)))
62 (if (or (not (integerp code))
63 (> (logand code 127) (length codes)))
64 nil
65 (with-output-to-string
66 (let* ((spec (elt codes (logand code 127)))
67 (b3 (lsh code -16))
68 (start1 (/= 0 (logand b3 128))) ;logtest!
69 (start1b (/= 0 (logand b3 64)))
70 (start2 (/= 0 (logand b3 32)))
71 (start2b (/= 0 (logand b3 16)))
72 (end1 (/= 0 (logand b3 8)))
73 (end1b (/= 0 (logand b3 4)))
74 (end2 (/= 0 (logand b3 2)))
75 (end2b (/= 0 (logand b3 1)))
76 (prefix (/= 0 (logand code 128)))
77 (single-char-p (or (= spec ?<) (= spec ?>)))
78 )
79 (write-char spec)
80 (write-char (if match match 32))
81 ;;; (if start1 (if single-char-p (write-char ?a) (write-char ?1)))
82 (if start1 (if single-char-p (write-char ? ) (write-char ?1)))
83 (if start2 (write-char ?2))
84 ;;; (if end1 (if single-char-p (write-char ?a) (write-char ?3)))
85 (if end1 (if single-char-p (write-char ? ) (write-char ?3)))
86 (if end2 (write-char ?4))
87 (if start1b (if single-char-p (write-char ?b) (write-char ?5)))
88 (if start2b (write-char ?6))
89 (if end1b (if single-char-p (write-char ?b) (write-char ?7)))
90 (if end2b (write-char ?8))
91 (if prefix (write-char ?p)))))))
92
93 (defun syntax-string-to-code (string)
94 "Return the internal syntax code equivalent to STRING.
95 STRING should be something acceptable as the second argument to
96 `modify-syntax-entry'.
97 If STRING is invalid, signal an error."
98 (let* ((bflag nil)
99 (b3 0)
100 (ch0 (aref string 0))
101 (len (length string))
102 (code (string-match (regexp-quote (char-to-string ch0))
103 (syntax-designator-chars)))
104 (i 2)
105 ch)
106 (or code
107 (error "Invalid syntax designator: %S" string))
108 (while (< i len)
109 (setq ch (aref string i))
110 (incf i)
111 (case ch
112 (?1 (setq b3 (logior b3 128)))
113 (?2 (setq b3 (logior b3 32)))
114 (?3 (setq b3 (logior b3 8)))
115 (?4 (setq b3 (logior b3 2)))
116 (?5 (setq b3 (logior b3 64)))
117 (?6 (setq b3 (logior b3 16)))
118 (?7 (setq b3 (logior b3 4)))
119 (?8 (setq b3 (logior b3 1)))
120 (?a (case ch0
121 (?< (setq b3 (logior b3 128)))
122 (?> (setq b3 (logior b3 8)))))
123 (?b (case ch0
124 (?< (setq b3 (logior b3 64) bflag t))
125 (?> (setq b3 (logior b3 4) bflag t))))
126 (?p (setq code (logior code (lsh 1 7))))
127 (?\ nil) ;; ignore for compatibility
128 (otherwise
129 (error "Invalid syntax description flag: %S" string))))
130 ;; default single char style if `b' has not been seen
131 (if (not bflag)
132 (case ch0
133 (?< (setq b3 (logior b3 128)))
134 (?> (setq b3 (logior b3 8)))))
135 (setq code (logior code (lsh b3 16)))
136 (if (and (> len 1)
137 ;; tough luck if you want to make space a paren!
138 (/= (aref string 1) ?\ ))
139 (setq code (cons code (aref string 1))))
140 code))
141
142 (defun modify-syntax-entry (char-range spec &optional table)
143 "Set syntax for the characters CHAR-RANGE according to string SPEC.
144 CHAR-RANGE is a single character or a range of characters,
145 as per `put-char-table'.
53 The syntax is changed only for table TABLE, which defaults to 146 The syntax is changed only for table TABLE, which defaults to
54 the current buffer's syntax table. 147 the current buffer's syntax table.
55 The first character of S should be one of the following: 148 The first character of SPEC should be one of the following:
56 Space whitespace syntax. w word constituent. 149 Space whitespace syntax. w word constituent.
57 _ symbol constituent. . punctuation. 150 _ symbol constituent. . punctuation.
58 \( open-parenthesis. \) close-parenthesis. 151 \( open-parenthesis. \) close-parenthesis.
59 \" string quote. \\ character-quote. 152 \" string quote. \\ character-quote.
60 $ paired delimiter. ' expression quote or prefix operator. 153 $ paired delimiter. ' expression quote or prefix operator.
61 < comment starter. > comment ender. 154 < comment starter. > comment ender.
62 / character-quote. @ inherit from `standard-syntax-table'. 155 / character-quote. @ inherit from `standard-syntax-table'.
63 156
64 Only single-character comment start and end sequences are represented thus. 157 Only single-character comment start and end sequences are represented thus.
65 Two-character sequences are represented as described below. 158 Two-character sequences are represented as described below.
66 The second character of S is the matching parenthesis, 159 The second character of SPEC is the matching parenthesis,
67 used only if the first character is `(' or `)'. 160 used only if the first character is `(' or `)'.
68 Any additional characters are flags. 161 Any additional characters are flags.
69 Defined flags are the characters 1, 2, 3, 4, 5, 6, 7, 8, p, a, and b. 162 Defined flags are the characters 1, 2, 3, 4, 5, 6, 7, 8, p, a, and b.
70 1 means C is the first of a two-char comment start sequence of style a. 163 1 means C is the first of a two-char comment start sequence of style a.
71 2 means C is the second character of such a sequence. 164 2 means C is the second character of such a sequence.
88 ((not table) 181 ((not table)
89 (setq table (syntax-table))) 182 (setq table (syntax-table)))
90 (t 183 (t
91 (setq table 184 (setq table
92 (wrong-type-argument 'syntax-table-p table)))) 185 (wrong-type-argument 'syntax-table-p table))))
93 (let* ((code nil) 186 (let ((code (syntax-string-to-code spec)))
94 (bflag nil) 187 (simple-set-syntax-entry char-range code table))
95 (b3 0) 188 nil)
96 i) 189
97 (setq code (string-match (regexp-quote (char-to-string (elt spec 0))) 190 (defun map-syntax-table (__function __table &optional __range)
98 (syntax-designator-chars))) 191 "Map FUNCTION over entries in syntax table TABLE, collapsing inheritance.
99 (or code 192 This is similar to `map-char-table', but works only on syntax tables, and
100 (error "Invalid syntax designator: %S" spec)) 193 collapses any entries that call for inheritance by invisibly substituting
101 (setq i 2) 194 the inherited values from the standard syntax table."
102 (while (< i (length spec)) 195 (check-argument-type 'syntax-table-p __table)
103 (let ((ch (elt spec i))) 196 (map-char-table #'(lambda (__key __value)
104 (setq i (1+ i)) 197 (if (eq ?@ (char-syntax-from-code __value))
105 (cond ((= ch ?1) 198 (map-char-table #'(lambda (__key __value)
106 (setq b3 (logior b3 128))) 199 (funcall __function
107 ((= ch ?2) 200 __key __value))
108 (setq b3 (logior b3 32))) 201 (standard-syntax-table)
109 ((= ch ?3) 202 __key)
110 (setq b3 (logior b3 8))) 203 (funcall __function __key __value)))
111 ((= ch ?4) 204 __table __range))
112 (setq b3 (logior b3 2)))
113 ((= ch ?5)
114 (setq b3 (logior b3 64)))
115 ((= ch ?6)
116 (setq b3 (logior b3 16)))
117 ((= ch ?7)
118 (setq b3 (logior b3 4)))
119 ((= ch ?8)
120 (setq b3 (logior b3 1)))
121 ((= ch ?a)
122 (cond ((= (elt spec 0) ?<)
123 (setq b3 (logior b3 128)))
124 ((= (elt spec 0) ?>)
125 (setq b3 (logior b3 8)))))
126 ((= ch ?b)
127 (cond ((= (elt spec 0) ?<)
128 (setq b3 (logior b3 64)
129 bflag t))
130 ((= (elt spec 0) ?>)
131 (setq b3 (logior b3 4)
132 bflag t))))
133 ((= ch ?p)
134 (setq code (logior code (lsh 1 7))))
135 ((= ch ?\ )
136 ;; ignore for compatibility
137 )
138 (t
139 (error "Invalid syntax description flag: %S" spec)))))
140 ;; default single char style is a if b has not been seen
141 (if (not bflag)
142 (cond ((= (elt spec 0) ?<)
143 (setq b3 (logior b3 128)))
144 ((= (elt spec 0) ?>)
145 (setq b3 (logior b3 8)))))
146 (aset table
147 char
148 (logior code
149 (if (and (> (length spec) 1)
150 ;; tough luck if you want to make space a paren!
151 (/= (elt spec 1) ?\ ))
152 ;; tough luck if you want to make \000 a paren!
153 (lsh (elt spec 1) 8)
154 0)
155 (lsh b3 16)))
156 nil))
157 205
158 ;(defun test-xm () 206 ;(defun test-xm ()
159 ; (let ((o (copy-syntax-table)) 207 ; (let ((o (copy-syntax-table))
160 ; (n (copy-syntax-table)) 208 ; (n (copy-syntax-table))
161 ; (codes (syntax-designator-chars)) 209 ; (codes (syntax-designator-chars))
180 ; (format "fucked with %S: %x %x" 228 ; (format "fucked with %S: %x %x"
181 ; spec (aref o ?a) (aref n ?a)))))))) 229 ; spec (aref o ?a) (aref n ?a))))))))
182 230
183 231
184 (defun describe-syntax-table (table stream) 232 (defun describe-syntax-table (table stream)
185 (let* (;(limit (cond ((numberp ctl-arrow) ctl-arrow) 233 (let (first-char
186 ; ((memq ctl-arrow '(t nil)) 256) 234 last-char
187 ; (t 160))) 235 prev-val
188 (describe-one #'(lambda (first last) 236 (describe-one
189 (let* ((tem (text-char-description first)) 237 (if (featurep 'mule)
190 (pos (length tem))) 238 #'(lambda (first last value stream)
191 (princ tem stream) 239 (if (equal first last)
192 (if (> last first) 240 (cond ((vectorp first)
193 (progn 241 (princ (format "%s, row %d\t"
194 (princ " .. " stream) 242 (charset-name
195 (setq tem (text-char-description last)) 243 (aref first 0))
196 (princ tem stream) 244 (aref first 1))
197 (setq pos (+ pos (length tem) 4)))) 245 stream))
198 (while (progn (write-char ?\ stream) 246 ((symbolp first)
199 (setq pos (1+ pos)) 247 (princ first stream)
200 (< pos 16)))) 248 (princ "\t" stream))
201 (describe-syntax-code (elt table first) stream)))) 249 (t
202 (let ((range 0) 250 (princ (text-char-description first) stream)
203 (i 0) 251 (princ "\t" stream)))
204 (code (elt table 0))) 252 (cond ((vectorp first)
205 (while (cond ((= i (length table)) 253 (princ (format "%s, rows %d .. %d\t"
206 (funcall describe-one (1- i) (1- i)) 254 (charset-name
207 nil) 255 (aref first 0))
208 ((eq code (elt table i)) 256 (aref first 1)
209 t) 257 (aref last 1))
210 (t 258 stream))
211 (funcall describe-one range (1- i)) 259 ((symbolp first)
212 (setq code (elt table i) 260 (princ (format "%s .. %s\t" first last) stream))
213 range i) 261 (t
214 t)) 262 (princ (format "%s .. %s\t"
215 (setq i (1+ i)))))) 263 (text-char-description first)
264 (text-char-description last))
265 stream))))
266 (describe-syntax-code value stream))
267 #'(lambda (first last value stream)
268 (let* ((tem (text-char-description first))
269 (pos (length tem))
270 ;;(limit (cond ((numberp ctl-arrow) ctl-arrow)
271 ;; ((memq ctl-arrow '(t nil)) 256)
272 ;; (t 160)))
273 )
274 (princ tem stream)
275 (if (> last first)
276 (progn
277 (princ " .. " stream)
278 (setq tem (text-char-description last))
279 (princ tem stream)
280 (setq pos (+ pos (length tem) 4))))
281 (while (progn (write-char ?\ stream)
282 (setq pos (1+ pos))
283 (< pos 16))))
284 (describe-syntax-code value stream)))))
285 (map-syntax-table
286 #'(lambda (range value)
287 (cond
288 ((not first-char)
289 (setq first-char range
290 last-char range
291 prev-val value))
292 ((and (equal value prev-val)
293 (or
294 (and (characterp range)
295 (characterp first-char)
296 (or (not (featurep 'mule))
297 (eq (char-charset range)
298 (char-charset first-char)))
299 (= (char-int last-char) (1- (char-int range))))
300 (and (vectorp range)
301 (vectorp first-char)
302 (eq (aref range 0) (aref first-char 0))
303 (= (aref last-char 1) (1- (aref range 1))))))
304 (setq last-char range))
305 (t
306 (funcall describe-one first-char last-char prev-val stream)
307 (setq first-char range
308 last-char range
309 prev-val value)))
310 nil)
311 table)
312 (if first-char
313 (funcall describe-one first-char last-char prev-val stream))))
216 314
217 (defun describe-syntax-code (code stream) 315 (defun describe-syntax-code (code stream)
218 (let ((codes (syntax-designator-chars)) 316 (let ((match (and (consp code) (cdr code)))
219 (invalid (gettext "**invalid**")) ;(empty "") ;constants 317 (invalid (gettext "**invalid**")) ;(empty "") ;constants
220 (standard-output (or stream standard-output)) 318 (standard-output (or stream standard-output))
221 ;; #### I18N3 should temporarily set buffer to output-translatable 319 ;; #### I18N3 should temporarily set buffer to output-translatable
222 (in #'(lambda (string) 320 (in #'(lambda (string)
223 (princ ",\n\t\t\t\t ") 321 (princ ",\n\t\t\t\t ")
224 (princ string)))) 322 (princ string)))
225 (if (or (not (integerp code)) 323 (syntax-string (syntax-code-to-string code)))
226 (> (logand code 127) (length codes))) 324 (if (consp code)
325 (setq code (car code)))
326 (if (null syntax-string)
227 (princ invalid) 327 (princ invalid)
228 (let* ((spec (elt codes (logand code 127))) 328 (princ syntax-string)
229 (match (logand (lsh code -8) 255)) 329 (princ "\tmeaning: ")
330 (princ (aref ["whitespace" "punctuation" "word-constituent"
331 "symbol-constituent" "open-paren" "close-paren"
332 "expression-prefix" "string-quote" "paired-delimiter"
333 "escape" "character-quote" "comment-begin" "comment-end"
334 "inherit" "extended-word-constituent"]
335 (logand code 127)))
336
337 (if match
338 (progn
339 (princ ", matches ")
340 (princ (text-char-description match))))
341 (let* ((spec (elt syntax-string 0))
230 (b3 (lsh code -16)) 342 (b3 (lsh code -16))
231 (start1 (/= 0 (logand b3 128))) ;logtest! 343 (start1 (/= 0 (logand b3 128))) ;logtest!
232 (start1b (/= 0 (logand b3 64))) 344 (start1b (/= 0 (logand b3 64)))
233 (start2 (/= 0 (logand b3 32))) 345 (start2 (/= 0 (logand b3 32)))
234 (start2b (/= 0 (logand b3 16))) 346 (start2b (/= 0 (logand b3 16)))
235 (end1 (/= 0 (logand b3 8))) 347 (end1 (/= 0 (logand b3 8)))
236 (end1b (/= 0 (logand b3 4))) 348 (end1b (/= 0 (logand b3 4)))
237 (end2 (/= 0 (logand b3 2))) 349 (end2 (/= 0 (logand b3 2)))
238 (end2b (/= 0 (logand b3 1))) 350 (end2b (/= 0 (logand b3 1)))
239 (prefix (/= 0 (logand code 128))) 351 (prefix (/= 0 (logand code 128)))
240 (single-char-p (or (= spec ?<) (= spec ?>))) 352 (single-char-p (or (= spec ?<) (= spec ?>))))
241 )
242 (write-char spec)
243 (write-char (if (= 0 match) 32 match))
244 ;; (if start1 (if single-char-p (write-char ?a) (write-char ?1)))
245 (if start1 (if single-char-p (write-char ? ) (write-char ?1)))
246 (if start2 (write-char ?2))
247 ;; (if end1 (if single-char-p (write-char ?a) (write-char ?3)))
248 (if end1 (if single-char-p (write-char ? ) (write-char ?3)))
249 (if end2 (write-char ?4))
250 (if start1b (if single-char-p (write-char ?b) (write-char ?5)))
251 (if start2b (write-char ?6))
252 (if end1b (if single-char-p (write-char ?b) (write-char ?7)))
253 (if end2b (write-char ?8))
254 (if prefix (write-char ?p))
255
256 (princ "\tmeaning: ")
257 (princ (aref ["whitespace" "punctuation" "word-constituent"
258 "symbol-constituent" "open-paren" "close-paren"
259 "expression-prefix" "string-quote" "paired-delimiter"
260 "escape" "character-quote" "comment-begin" "comment-end"
261 "inherit" "extended-word-constituent"]
262 (logand code 127)))
263
264 (if (/= 0 match)
265 (progn
266 (princ ", matches ")
267 (princ (text-char-description match))))
268 (if start1 353 (if start1
269 (if single-char-p 354 (if single-char-p
270 (princ ", style A") 355 (princ ", style A")
271 (funcall in (gettext "first character of comment-start sequence A")))) 356 (funcall in
357 (gettext "first character of comment-start sequence A"))))
272 (if start2 358 (if start2
273 (funcall in (gettext "second character of comment-start sequence A"))) 359 (funcall in
360 (gettext "second character of comment-start sequence A")))
274 (if end1 361 (if end1
275 (if single-char-p 362 (if single-char-p
276 (princ ", style A") 363 (princ ", style A")
277 (funcall in (gettext "first character of comment-end sequence A")))) 364 (funcall in
365 (gettext "first character of comment-end sequence A"))))
278 (if end2 366 (if end2
279 (funcall in (gettext "second character of comment-end sequence A"))) 367 (funcall in
368 (gettext "second character of comment-end sequence A")))
280 (if start1b 369 (if start1b
281 (if single-char-p 370 (if single-char-p
282 (princ ", style B") 371 (princ ", style B")
283 (funcall in (gettext "first character of comment-start sequence B")))) 372 (funcall in
373 (gettext "first character of comment-start sequence B"))))
284 (if start2b 374 (if start2b
285 (funcall in (gettext "second character of comment-start sequence B"))) 375 (funcall in
376 (gettext "second character of comment-start sequence B")))
286 (if end1b 377 (if end1b
287 (if single-char-p 378 (if single-char-p
288 (princ ", style B") 379 (princ ", style B")
289 (funcall in (gettext "first character of comment-end sequence B")))) 380 (funcall in
381 (gettext "first character of comment-end sequence B"))))
290 (if end2b 382 (if end2b
291 (funcall in (gettext "second character of comment-end sequence B"))) 383 (funcall in
384 (gettext "second character of comment-end sequence B")))
292 (if prefix 385 (if prefix
293 (funcall in (gettext "prefix character for `backward-prefix-chars'"))))) 386 (funcall in
294 (terpri stream))) 387 (gettext "prefix character for `backward-prefix-chars'"))))
388 (terpri stream))))
295 389
296 (defun symbol-near-point () 390 (defun symbol-near-point ()
297 "Return the first textual item to the nearest point." 391 "Return the first textual item to the nearest point."
298 (interactive) 392 (interactive)
299 ;alg stolen from etag.el 393 ;alg stolen from etag.el