|
0
|
1 ;; Syntax-table hacking stuff, moved from syntax.c
|
|
|
2 ;; Copyright (C) 1993 Free Software Foundation, Inc.
|
|
|
3
|
|
|
4 ;; This file is part of XEmacs.
|
|
|
5
|
|
|
6 ;; 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 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
9 ;; any later version.
|
|
|
10
|
|
|
11 ;; XEmacs is distributed in the hope that it will be useful, but
|
|
|
12 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
|
14 ;; General Public License for more details.
|
|
|
15
|
|
|
16 ;; 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 Free
|
|
|
18 ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
|
19
|
|
|
20 ;;; Synched up with: FSF 19.28.
|
|
|
21 ;;; Note: FSF does not have a file syntax.el. This stuff is
|
|
|
22 ;;; in syntax.c. See comments there about not merging past 19.28.
|
|
|
23
|
|
|
24 (defun make-syntax-table (&optional oldtable)
|
|
|
25 "Return a new syntax table.
|
|
|
26 It inherits all letters and control characters from the standard
|
|
|
27 syntax table; other characters are copied from the standard syntax table."
|
|
|
28 (if oldtable
|
|
|
29 (copy-syntax-table oldtable)
|
|
|
30 (let ((table (copy-syntax-table))
|
|
|
31 i)
|
|
|
32 (setq i 0)
|
|
|
33 (while (<= i 31)
|
|
|
34 (aset table i 13)
|
|
|
35 (setq i (1+ i)))
|
|
|
36 (setq i ?A)
|
|
|
37 (while (<= i ?Z)
|
|
|
38 (aset table i 13)
|
|
|
39 (setq i (1+ i)))
|
|
|
40 (setq i ?a)
|
|
|
41 (while (<= i ?z)
|
|
|
42 (aset table i 13)
|
|
|
43 (setq i (1+ i)))
|
|
|
44 (setq i 128)
|
|
|
45 (while (<= i 255)
|
|
|
46 (aset table i 13)
|
|
|
47 (setq i (1+ i)))
|
|
|
48 table)))
|
|
|
49
|
|
|
50 (defun modify-syntax-entry (char spec &optional table)
|
|
|
51 "Set syntax for character CHAR according to string S.
|
|
|
52 The syntax is changed only for table TABLE, which defaults to
|
|
|
53 the current buffer's syntax table.
|
|
|
54 The first character of S should be one of the following:
|
|
|
55 Space whitespace syntax. w word constituent.
|
|
|
56 _ symbol constituent. . punctuation.
|
|
|
57 \( open-parenthesis. \) close-parenthesis.
|
|
|
58 \" string quote. \\ character-quote.
|
|
|
59 $ paired delimiter. ' expression quote or prefix operator.
|
|
|
60 < comment starter. > comment ender.
|
|
|
61 / character-quote. @ inherit from `standard-syntax-table'.
|
|
|
62
|
|
|
63 Only single-character comment start and end sequences are represented thus.
|
|
|
64 Two-character sequences are represented as described below.
|
|
|
65 The second character of S is the matching parenthesis,
|
|
|
66 used only if the first character is `(' or `)'.
|
|
|
67 Any additional characters are flags.
|
|
|
68 Defined flags are the characters 1, 2, 3, 4, 5, 6, 7, 8, p, a, and b.
|
|
|
69 1 means C is the first of a two-char comment start sequence of style a.
|
|
|
70 2 means C is the second character of such a sequence.
|
|
|
71 3 means C is the first of a two-char comment end sequence of style a.
|
|
|
72 4 means C is the second character of such a sequence.
|
|
|
73 5 means C is the first of a two-char comment start sequence of style b.
|
|
|
74 6 means C is the second character of such a sequence.
|
|
|
75 7 means C is the first of a two-char comment end sequence of style b.
|
|
|
76 8 means C is the second character of such a sequence.
|
|
|
77 p means C is a prefix character for `backward-prefix-chars';
|
|
|
78 such characters are treated as whitespace when they occur
|
|
|
79 between expressions.
|
|
|
80 a means C is comment starter or comment ender for comment style a (default)
|
|
|
81 b means C is comment starter or comment ender for comment style b."
|
|
|
82 (interactive
|
|
|
83 ;; I really don't know why this is interactive
|
|
|
84 ;; help-form should at least be made useful whilst reading the second arg
|
|
|
85 "cSet syntax for character: \nsSet syntax for %c to: ")
|
|
|
86 (cond ((syntax-table-p table))
|
|
|
87 ((not table)
|
|
|
88 (setq table (syntax-table)))
|
|
|
89 (t
|
|
|
90 (setq table
|
|
|
91 (wrong-type-argument 'syntax-table-p table))))
|
|
|
92 (let* ((code nil)
|
|
|
93 (bflag nil)
|
|
|
94 (b3 0)
|
|
|
95 i)
|
|
|
96 (setq code (string-match (regexp-quote (char-to-string (elt spec 0)))
|
|
|
97 (syntax-designator-chars)))
|
|
|
98 (or code
|
|
|
99 (error "Invalid syntax designator: %S" spec))
|
|
|
100 (setq i 2)
|
|
|
101 (while (< i (length spec))
|
|
|
102 (let ((ch (elt spec i)))
|
|
|
103 (setq i (1+ i))
|
|
|
104 (cond ((= ch ?1)
|
|
|
105 (setq b3 (logior b3 128)))
|
|
|
106 ((= ch ?2)
|
|
|
107 (setq b3 (logior b3 32)))
|
|
|
108 ((= ch ?3)
|
|
|
109 (setq b3 (logior b3 8)))
|
|
|
110 ((= ch ?4)
|
|
|
111 (setq b3 (logior b3 2)))
|
|
|
112 ((= ch ?5)
|
|
|
113 (setq b3 (logior b3 64)))
|
|
|
114 ((= ch ?6)
|
|
|
115 (setq b3 (logior b3 16)))
|
|
|
116 ((= ch ?7)
|
|
|
117 (setq b3 (logior b3 4)))
|
|
|
118 ((= ch ?8)
|
|
|
119 (setq b3 (logior b3 1)))
|
|
|
120 ((= ch ?a)
|
|
|
121 (cond ((= (elt spec 0) ?<)
|
|
|
122 (setq b3 (logior b3 128)))
|
|
|
123 ((= (elt spec 0) ?>)
|
|
|
124 (setq b3 (logior b3 8)))))
|
|
|
125 ((= ch ?b)
|
|
|
126 (cond ((= (elt spec 0) ?<)
|
|
|
127 (setq b3 (logior b3 64)
|
|
|
128 bflag t))
|
|
|
129 ((= (elt spec 0) ?>)
|
|
|
130 (setq b3 (logior b3 4)
|
|
|
131 bflag t))))
|
|
|
132 ((= ch ?p)
|
|
|
133 (setq code (logior code (lsh 1 7))))
|
|
|
134 ((= ch ?\ )
|
|
|
135 ;; ignore for compatibility
|
|
|
136 )
|
|
|
137 (t
|
|
|
138 (error "Invalid syntax description flag: %S" spec)))))
|
|
|
139 ;; default single char style is a if b has not been seen
|
|
|
140 (if (not bflag)
|
|
|
141 (cond ((= (elt spec 0) ?<)
|
|
|
142 (setq b3 (logior b3 128)))
|
|
|
143 ((= (elt spec 0) ?>)
|
|
|
144 (setq b3 (logior b3 8)))))
|
|
|
145 (aset table
|
|
|
146 char
|
|
|
147 (logior code
|
|
|
148 (if (and (> (length spec) 1)
|
|
|
149 ;; tough luck if you want to make space a paren!
|
|
|
150 (/= (elt spec 1) ?\ ))
|
|
|
151 ;; tough luck if you want to make \000 a paren!
|
|
|
152 (lsh (elt spec 1) 8)
|
|
|
153 0)
|
|
|
154 (lsh b3 16)))
|
|
|
155 nil))
|
|
|
156
|
|
|
157 ;(defun test-xm ()
|
|
|
158 ; (let ((o (copy-syntax-table))
|
|
|
159 ; (n (copy-syntax-table))
|
|
|
160 ; (codes (syntax-designator-chars))
|
|
|
161 ; (flags "12345678abp"))
|
|
|
162 ; (while t
|
|
|
163 ; (let ((spec (concat (char-to-string (elt codes
|
|
|
164 ; (random (length codes))))))
|
|
|
165 ; (if (= (random 4) 0)
|
|
|
166 ; "b"
|
|
|
167 ; " ")
|
|
|
168 ; (let* ((n (random 4))
|
|
|
169 ; (s (make-string n 0)))
|
|
|
170 ; (while (> n 0)
|
|
|
171 ; (setq n (1- n))
|
|
|
172 ; (aset s n (aref flags (random (length flags)))))
|
|
|
173 ; s))))
|
|
|
174 ; (message "%S..." spec)
|
|
|
175 ; (modify-syntax-entry ?a spec o)
|
|
|
176 ; (xmodify-syntax-entry ?a spec n)
|
|
|
177 ; (or (= (aref o ?a) (aref n ?a))
|
|
|
178 ; (error "%s"
|
|
|
179 ; (format "fucked with %S: %x %x"
|
|
|
180 ; spec (aref o ?a) (aref n ?a))))))))
|
|
|
181
|
|
|
182
|
|
|
183 (defun describe-syntax-table (table stream)
|
|
|
184 (let* (;(limit (cond ((numberp ctl-arrow) ctl-arrow)
|
|
|
185 ; ((memq ctl-arrow '(t nil)) 256)
|
|
|
186 ; (t 160)))
|
|
|
187 (describe-one #'(lambda (first last)
|
|
|
188 (let* ((tem (text-char-description first))
|
|
|
189 (pos (length tem)))
|
|
|
190 (princ tem stream)
|
|
|
191 (if (> last first)
|
|
|
192 (progn
|
|
|
193 (princ " .. " stream)
|
|
|
194 (setq tem (text-char-description last))
|
|
|
195 (princ tem stream)
|
|
|
196 (setq pos (+ pos (length tem) 4))))
|
|
|
197 (while (progn (write-char ?\ stream)
|
|
|
198 (setq pos (1+ pos))
|
|
|
199 (< pos 16))))
|
|
|
200 (describe-syntax-code (elt table first) stream))))
|
|
|
201 (let ((range 0)
|
|
|
202 (i 0)
|
|
|
203 (code (elt table 0)))
|
|
|
204 (while (cond ((= i (length table))
|
|
|
205 (funcall describe-one (1- i) (1- i))
|
|
|
206 nil)
|
|
|
207 ((eq code (elt table i))
|
|
|
208 t)
|
|
|
209 (t
|
|
|
210 (funcall describe-one range (1- i))
|
|
|
211 (setq code (elt table i)
|
|
|
212 range i)
|
|
|
213 t))
|
|
|
214 (setq i (1+ i))))))
|
|
|
215
|
|
|
216 (defun describe-syntax-code (code stream)
|
|
|
217 (let ((codes (syntax-designator-chars))
|
|
|
218 (invalid (gettext "**invalid**")) ;(empty "") ;constants
|
|
|
219 (standard-output (or stream standard-output))
|
|
|
220 ;; #### I18N3 should temporarily set buffer to output-translatable
|
|
|
221 (in #'(lambda (string)
|
|
|
222 (princ ",\n\t\t\t\t ")
|
|
|
223 (princ string))))
|
|
|
224 (if (or (not (integerp code))
|
|
|
225 (> (logand code 127) (length codes)))
|
|
|
226 (princ invalid)
|
|
|
227 (let* ((spec (elt codes (logand code 127)))
|
|
|
228 (match (logand (lsh code -8) 255))
|
|
|
229 (b3 (lsh code -16))
|
|
|
230 (start1 (/= 0 (logand b3 128))) ;logtest!
|
|
|
231 (start1b (/= 0 (logand b3 64)))
|
|
|
232 (start2 (/= 0 (logand b3 32)))
|
|
|
233 (start2b (/= 0 (logand b3 16)))
|
|
|
234 (end1 (/= 0 (logand b3 8)))
|
|
|
235 (end1b (/= 0 (logand b3 4)))
|
|
|
236 (end2 (/= 0 (logand b3 2)))
|
|
|
237 (end2b (/= 0 (logand b3 1)))
|
|
|
238 (prefix (/= 0 (logand code 128)))
|
|
|
239 (single-char-p (or (= spec ?<) (= spec ?>)))
|
|
|
240 )
|
|
|
241 (write-char spec)
|
|
|
242 (write-char (if (= 0 match) 32 match))
|
|
|
243 ;; (if start1 (if single-char-p (write-char ?a) (write-char ?1)))
|
|
|
244 (if start1 (if single-char-p (write-char ? ) (write-char ?1)))
|
|
|
245 (if start2 (write-char ?2))
|
|
|
246 ;; (if end1 (if single-char-p (write-char ?a) (write-char ?3)))
|
|
|
247 (if end1 (if single-char-p (write-char ? ) (write-char ?3)))
|
|
|
248 (if end2 (write-char ?4))
|
|
|
249 (if start1b (if single-char-p (write-char ?b) (write-char ?5)))
|
|
|
250 (if start2b (write-char ?6))
|
|
|
251 (if end1b (if single-char-p (write-char ?b) (write-char ?7)))
|
|
|
252 (if end2b (write-char ?8))
|
|
|
253 (if prefix (write-char ?p))
|
|
|
254
|
|
|
255 (princ "\tmeaning: ")
|
|
|
256 (princ (aref ["whitespace" "punctuation" "word-constituent"
|
|
|
257 "symbol-constituent" "open-paren" "close-paren"
|
|
|
258 "expression-prefix" "string-quote" "paired-delimiter"
|
|
|
259 "escape" "character-quote" "comment-begin" "comment-end"
|
|
|
260 "inherit" "extended-word-constituent"]
|
|
|
261 (logand code 127)))
|
|
|
262
|
|
|
263 (if (/= 0 match)
|
|
|
264 (progn
|
|
|
265 (princ ", matches ")
|
|
|
266 (princ (text-char-description match))))
|
|
|
267 (if start1
|
|
|
268 (if single-char-p
|
|
|
269 (princ ", style A")
|
|
|
270 (funcall in (gettext "first character of comment-start sequence A"))))
|
|
|
271 (if start2
|
|
|
272 (funcall in (gettext "second character of comment-start sequence A")))
|
|
|
273 (if end1
|
|
|
274 (if single-char-p
|
|
|
275 (princ ", style A")
|
|
|
276 (funcall in (gettext "first character of comment-end sequence A"))))
|
|
|
277 (if end2
|
|
|
278 (funcall in (gettext "second character of comment-end sequence A")))
|
|
|
279 (if start1b
|
|
|
280 (if single-char-p
|
|
|
281 (princ ", style B")
|
|
|
282 (funcall in (gettext "first character of comment-start sequence B"))))
|
|
|
283 (if start2b
|
|
|
284 (funcall in (gettext "second character of comment-start sequence B")))
|
|
|
285 (if end1b
|
|
|
286 (if single-char-p
|
|
|
287 (princ ", style B")
|
|
|
288 (funcall in (gettext "first character of comment-end sequence B"))))
|
|
|
289 (if end2b
|
|
|
290 (funcall in (gettext "second character of comment-end sequence B")))
|
|
|
291 (if prefix
|
|
|
292 (funcall in (gettext "prefix character for `backward-prefix-chars'")))))
|
|
|
293 (terpri stream)))
|
|
|
294
|
|
|
295 (defun symbol-near-point ()
|
|
|
296 "Return the first textual item to the nearest point."
|
|
|
297 (interactive)
|
|
|
298 ;alg stolen from etag.el
|
|
|
299 (save-excursion
|
|
|
300 (if (not (memq (char-syntax (preceding-char)) '(?w ?_)))
|
|
|
301 (while (not (looking-at "\\sw\\|\\s_\\|\\'"))
|
|
|
302 (forward-char 1)))
|
|
|
303 (while (looking-at "\\sw\\|\\s_")
|
|
|
304 (forward-char 1))
|
|
|
305 (if (re-search-backward "\\sw\\|\\s_" nil t)
|
|
|
306 (regexp-quote
|
|
|
307 (progn (forward-char 1)
|
|
|
308 (buffer-substring (point)
|
|
|
309 (progn (forward-sexp -1)
|
|
|
310 (while (looking-at "\\s'")
|
|
|
311 (forward-char 1))
|
|
|
312 (point)))))
|
|
|
313 nil)))
|
