|
0
|
1 ;; Syntax-table hacking stuff, moved from syntax.c
|
|
|
2 ;; Copyright (C) 1993 Free Software Foundation, Inc.
|
|
70
|
3 ;; Copyright (C) 1995 Sun Microsystems.
|
|
0
|
4
|
|
|
5 ;; This file is part of XEmacs.
|
|
|
6
|
|
|
7 ;; XEmacs is free software; you can redistribute it and/or modify it
|
|
|
8 ;; under the terms of the GNU General Public License as published by
|
|
|
9 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
10 ;; any later version.
|
|
|
11
|
|
|
12 ;; XEmacs is distributed in the hope that it will be useful, but
|
|
|
13 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
|
15 ;; General Public License for more details.
|
|
|
16
|
|
|
17 ;; You should have received a copy of the GNU General Public License
|
|
16
|
18 ;; along with XEmacs; see the file COPYING. If not, write to the
|
|
70
|
19 ;; Free Software Foundation, 59 Temple Place - Suite 330,
|
|
16
|
20 ;; Boston, MA 02111-1307, USA.
|
|
0
|
21
|
|
|
22 ;;; Synched up with: FSF 19.28.
|
|
|
23 ;;; Note: FSF does not have a file syntax.el. This stuff is
|
|
|
24 ;;; in syntax.c. See comments there about not merging past 19.28.
|
|
|
25
|
|
70
|
26 ;; Significantly hacked upon by Ben Wing.
|
|
|
27
|
|
0
|
28 (defun make-syntax-table (&optional oldtable)
|
|
|
29 "Return a new syntax table.
|
|
70
|
30 It inherits all characters from the standard syntax table."
|
|
|
31 (make-char-table 'syntax))
|
|
|
32
|
|
|
33 (defun simple-set-syntax-entry (char spec table)
|
|
|
34 (put-char-table char spec table))
|
|
|
35
|
|
|
36 (defun char-syntax-from-code (code)
|
|
|
37 "Extract the syntax designator from the internal syntax code CODE.
|
|
|
38 CODE is the value actually contained in the syntax table."
|
|
|
39 (if (consp code)
|
|
|
40 (setq code (car code)))
|
|
|
41 (aref (syntax-designator-chars) (logand code 127)))
|
|
|
42
|
|
|
43 (defun set-char-syntax-in-code (code desig)
|
|
|
44 "Return a new internal syntax code whose syntax designator is DESIG.
|
|
|
45 Other characteristics are the same as in CODE."
|
|
|
46 (let ((newcode (if (consp code) (car code) code)))
|
|
|
47 (setq newcode (logior (string-match
|
|
|
48 (regexp-quote (char-to-string desig))
|
|
|
49 (syntax-designator-chars))
|
|
|
50 (logand newcode (lognot 127))))
|
|
|
51 (if (consp code) (cons newcode (cdr code))
|
|
|
52 newcode)))
|
|
0
|
53
|
|
70
|
54 (defun syntax-code-to-string (code)
|
|
|
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'.
|
|
0
|
146 The syntax is changed only for table TABLE, which defaults to
|
|
|
147 the current buffer's syntax table.
|
|
70
|
148 The first character of SPEC should be one of the following:
|
|
0
|
149 Space whitespace syntax. w word constituent.
|
|
|
150 _ symbol constituent. . punctuation.
|
|
|
151 \( open-parenthesis. \) close-parenthesis.
|
|
|
152 \" string quote. \\ character-quote.
|
|
|
153 $ paired delimiter. ' expression quote or prefix operator.
|
|
|
154 < comment starter. > comment ender.
|
|
70
|
155 / character-quote. @ inherit from `standard-syntax-table'.
|
|
0
|
156
|
|
|
157 Only single-character comment start and end sequences are represented thus.
|
|
|
158 Two-character sequences are represented as described below.
|
|
70
|
159 The second character of SPEC is the matching parenthesis,
|
|
0
|
160 used only if the first character is `(' or `)'.
|
|
|
161 Any additional characters are flags.
|
|
|
162 Defined flags are the characters 1, 2, 3, 4, 5, 6, 7, 8, p, a, and b.
|
|
|
163 1 means C is the first of a two-char comment start sequence of style a.
|
|
|
164 2 means C is the second character of such a sequence.
|
|
|
165 3 means C is the first of a two-char comment end sequence of style a.
|
|
|
166 4 means C is the second character of such a sequence.
|
|
|
167 5 means C is the first of a two-char comment start sequence of style b.
|
|
|
168 6 means C is the second character of such a sequence.
|
|
|
169 7 means C is the first of a two-char comment end sequence of style b.
|
|
|
170 8 means C is the second character of such a sequence.
|
|
|
171 p means C is a prefix character for `backward-prefix-chars';
|
|
|
172 such characters are treated as whitespace when they occur
|
|
|
173 between expressions.
|
|
|
174 a means C is comment starter or comment ender for comment style a (default)
|
|
|
175 b means C is comment starter or comment ender for comment style b."
|
|
|
176 (interactive
|
|
|
177 ;; I really don't know why this is interactive
|
|
|
178 ;; help-form should at least be made useful whilst reading the second arg
|
|
|
179 "cSet syntax for character: \nsSet syntax for %c to: ")
|
|
|
180 (cond ((syntax-table-p table))
|
|
|
181 ((not table)
|
|
|
182 (setq table (syntax-table)))
|
|
|
183 (t
|
|
|
184 (setq table
|
|
|
185 (wrong-type-argument 'syntax-table-p table))))
|
|
70
|
186 (let ((code (syntax-string-to-code spec)))
|
|
|
187 (simple-set-syntax-entry char-range code table))
|
|
|
188 nil)
|
|
|
189
|
|
|
190 (defun map-syntax-table (__function __table &optional __range)
|
|
|
191 "Map FUNCTION over entries in syntax table TABLE, collapsing inheritance.
|
|
|
192 This is similar to `map-char-table', but works only on syntax tables, and
|
|
|
193 collapses any entries that call for inheritance by invisibly substituting
|
|
|
194 the inherited values from the standard syntax table."
|
|
|
195 (check-argument-type 'syntax-table-p __table)
|
|
|
196 (map-char-table #'(lambda (__key __value)
|
|
|
197 (if (eq ?@ (char-syntax-from-code __value))
|
|
|
198 (map-char-table #'(lambda (__key __value)
|
|
|
199 (funcall __function
|
|
|
200 __key __value))
|
|
|
201 (standard-syntax-table)
|
|
|
202 __key)
|
|
|
203 (funcall __function __key __value)))
|
|
|
204 __table __range))
|
|
0
|
205
|
|
|
206 ;(defun test-xm ()
|
|
|
207 ; (let ((o (copy-syntax-table))
|
|
|
208 ; (n (copy-syntax-table))
|
|
|
209 ; (codes (syntax-designator-chars))
|
|
|
210 ; (flags "12345678abp"))
|
|
|
211 ; (while t
|
|
|
212 ; (let ((spec (concat (char-to-string (elt codes
|
|
|
213 ; (random (length codes))))))
|
|
|
214 ; (if (= (random 4) 0)
|
|
|
215 ; "b"
|
|
|
216 ; " ")
|
|
|
217 ; (let* ((n (random 4))
|
|
|
218 ; (s (make-string n 0)))
|
|
|
219 ; (while (> n 0)
|
|
|
220 ; (setq n (1- n))
|
|
|
221 ; (aset s n (aref flags (random (length flags)))))
|
|
|
222 ; s))))
|
|
|
223 ; (message "%S..." spec)
|
|
|
224 ; (modify-syntax-entry ?a spec o)
|
|
|
225 ; (xmodify-syntax-entry ?a spec n)
|
|
|
226 ; (or (= (aref o ?a) (aref n ?a))
|
|
|
227 ; (error "%s"
|
|
|
228 ; (format "fucked with %S: %x %x"
|
|
|
229 ; spec (aref o ?a) (aref n ?a))))))))
|
|
|
230
|
|
|
231
|
|
|
232 (defun describe-syntax-table (table stream)
|
|
70
|
233 (let (first-char
|
|
|
234 last-char
|
|
|
235 prev-val
|
|
|
236 (describe-one
|
|
|
237 (if (featurep 'mule)
|
|
|
238 #'(lambda (first last value stream)
|
|
|
239 (if (equal first last)
|
|
|
240 (cond ((vectorp first)
|
|
|
241 (princ (format "%s, row %d\t"
|
|
|
242 (charset-name
|
|
|
243 (aref first 0))
|
|
|
244 (aref first 1))
|
|
|
245 stream))
|
|
|
246 ((symbolp first)
|
|
|
247 (princ first stream)
|
|
|
248 (princ "\t" stream))
|
|
|
249 (t
|
|
|
250 (princ (text-char-description first) stream)
|
|
|
251 (princ "\t" stream)))
|
|
|
252 (cond ((vectorp first)
|
|
|
253 (princ (format "%s, rows %d .. %d\t"
|
|
|
254 (charset-name
|
|
|
255 (aref first 0))
|
|
|
256 (aref first 1)
|
|
|
257 (aref last 1))
|
|
|
258 stream))
|
|
|
259 ((symbolp first)
|
|
|
260 (princ (format "%s .. %s\t" first last) stream))
|
|
|
261 (t
|
|
|
262 (princ (format "%s .. %s\t"
|
|
|
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))))
|
|
0
|
314
|
|
|
315 (defun describe-syntax-code (code stream)
|
|
70
|
316 (let ((match (and (consp code) (cdr code)))
|
|
0
|
317 (invalid (gettext "**invalid**")) ;(empty "") ;constants
|
|
|
318 (standard-output (or stream standard-output))
|
|
|
319 ;; #### I18N3 should temporarily set buffer to output-translatable
|
|
|
320 (in #'(lambda (string)
|
|
|
321 (princ ",\n\t\t\t\t ")
|
|
70
|
322 (princ string)))
|
|
|
323 (syntax-string (syntax-code-to-string code)))
|
|
|
324 (if (consp code)
|
|
|
325 (setq code (car code)))
|
|
|
326 (if (null syntax-string)
|
|
0
|
327 (princ invalid)
|
|
70
|
328 (princ syntax-string)
|
|
|
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))
|
|
0
|
342 (b3 (lsh code -16))
|
|
|
343 (start1 (/= 0 (logand b3 128))) ;logtest!
|
|
|
344 (start1b (/= 0 (logand b3 64)))
|
|
|
345 (start2 (/= 0 (logand b3 32)))
|
|
|
346 (start2b (/= 0 (logand b3 16)))
|
|
|
347 (end1 (/= 0 (logand b3 8)))
|
|
|
348 (end1b (/= 0 (logand b3 4)))
|
|
|
349 (end2 (/= 0 (logand b3 2)))
|
|
|
350 (end2b (/= 0 (logand b3 1)))
|
|
|
351 (prefix (/= 0 (logand code 128)))
|
|
70
|
352 (single-char-p (or (= spec ?<) (= spec ?>))))
|
|
0
|
353 (if start1
|
|
|
354 (if single-char-p
|
|
|
355 (princ ", style A")
|
|
70
|
356 (funcall in
|
|
|
357 (gettext "first character of comment-start sequence A"))))
|
|
0
|
358 (if start2
|
|
70
|
359 (funcall in
|
|
|
360 (gettext "second character of comment-start sequence A")))
|
|
0
|
361 (if end1
|
|
|
362 (if single-char-p
|
|
|
363 (princ ", style A")
|
|
70
|
364 (funcall in
|
|
|
365 (gettext "first character of comment-end sequence A"))))
|
|
0
|
366 (if end2
|
|
70
|
367 (funcall in
|
|
|
368 (gettext "second character of comment-end sequence A")))
|
|
0
|
369 (if start1b
|
|
|
370 (if single-char-p
|
|
|
371 (princ ", style B")
|
|
70
|
372 (funcall in
|
|
|
373 (gettext "first character of comment-start sequence B"))))
|
|
0
|
374 (if start2b
|
|
70
|
375 (funcall in
|
|
|
376 (gettext "second character of comment-start sequence B")))
|
|
0
|
377 (if end1b
|
|
|
378 (if single-char-p
|
|
|
379 (princ ", style B")
|
|
70
|
380 (funcall in
|
|
|
381 (gettext "first character of comment-end sequence B"))))
|
|
0
|
382 (if end2b
|
|
70
|
383 (funcall in
|
|
|
384 (gettext "second character of comment-end sequence B")))
|
|
0
|
385 (if prefix
|
|
70
|
386 (funcall in
|
|
|
387 (gettext "prefix character for `backward-prefix-chars'"))))
|
|
|
388 (terpri stream))))
|
|
0
|
389
|
|
|
390 (defun symbol-near-point ()
|
|
|
391 "Return the first textual item to the nearest point."
|
|
|
392 (interactive)
|
|
|
393 ;alg stolen from etag.el
|
|
|
394 (save-excursion
|
|
|
395 (if (not (memq (char-syntax (preceding-char)) '(?w ?_)))
|
|
|
396 (while (not (looking-at "\\sw\\|\\s_\\|\\'"))
|
|
|
397 (forward-char 1)))
|
|
|
398 (while (looking-at "\\sw\\|\\s_")
|
|
|
399 (forward-char 1))
|
|
|
400 (if (re-search-backward "\\sw\\|\\s_" nil t)
|
|
|
401 (regexp-quote
|
|
|
402 (progn (forward-char 1)
|
|
|
403 (buffer-substring (point)
|
|
|
404 (progn (forward-sexp -1)
|
|
|
405 (while (looking-at "\\s'")
|
|
|
406 (forward-char 1))
|
|
|
407 (point)))))
|
|
|
408 nil)))
|
