|
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
|
