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