|
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
|
|
16
|
17 ;; along with XEmacs; see the file COPYING. If not, write to the
|
|
|
18 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
|
19 ;; Boston, MA 02111-1307, USA.
|
|
0
|
20
|
|
|
21 ;;; Synched up with: FSF 19.28.
|
|
|
22 ;;; 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
|
|
|
25 (defun make-syntax-table (&optional oldtable)
|
|
|
26 "Return a new syntax table.
|
|
|
27 It inherits all letters and control characters from the standard
|
|
|
28 syntax table; other characters are copied from the standard syntax table."
|
|
|
29 (if oldtable
|
|
|
30 (copy-syntax-table oldtable)
|
|
|
31 (let ((table (copy-syntax-table))
|
|
|
32 i)
|
|
|
33 (setq i 0)
|
|
|
34 (while (<= i 31)
|
|
|
35 (aset table i 13)
|
|
|
36 (setq i (1+ i)))
|
|
|
37 (setq i ?A)
|
|
|
38 (while (<= i ?Z)
|
|
|
39 (aset table i 13)
|
|
|
40 (setq i (1+ i)))
|
|
|
41 (setq i ?a)
|
|
|
42 (while (<= i ?z)
|
|
|
43 (aset table i 13)
|
|
|
44 (setq i (1+ i)))
|
|
|
45 (setq i 128)
|
|
|
46 (while (<= i 255)
|
|
|
47 (aset table i 13)
|
|
|
48 (setq i (1+ i)))
|
|
|
49 table)))
|
|
|
50
|
|
|
51 (defun modify-syntax-entry (char spec &optional table)
|
|
|
52 "Set syntax for character CHAR according to string S.
|
|
|
53 The syntax is changed only for table TABLE, which defaults to
|
|
|
54 the current buffer's syntax table.
|
|
|
55 The first character of S should be one of the following:
|
|
|
56 Space whitespace syntax. w word constituent.
|
|
|
57 _ symbol constituent. . punctuation.
|
|
|
58 \( open-parenthesis. \) close-parenthesis.
|
|
|
59 \" string quote. \\ character-quote.
|
|
|
60 $ paired delimiter. ' expression quote or prefix operator.
|
|
|
61 < comment starter. > comment ender.
|
|
|
62 / character-quote. @ inherit from `standard-syntax-table'.
|
|
|
63
|
|
|
64 Only single-character comment start and end sequences are represented thus.
|
|
|
65 Two-character sequences are represented as described below.
|
|
|
66 The second character of S is the matching parenthesis,
|
|
|
67 used only if the first character is `(' or `)'.
|
|
|
68 Any additional characters are flags.
|
|
|
69 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.
|
|
|
71 2 means C is the second character of such a sequence.
|
|
|
72 3 means C is the first of a two-char comment end sequence of style a.
|
|
|
73 4 means C is the second character of such a sequence.
|
|
|
74 5 means C is the first of a two-char comment start sequence of style b.
|
|
|
75 6 means C is the second character of such a sequence.
|
|
|
76 7 means C is the first of a two-char comment end sequence of style b.
|
|
|
77 8 means C is the second character of such a sequence.
|
|
|
78 p means C is a prefix character for `backward-prefix-chars';
|
|
|
79 such characters are treated as whitespace when they occur
|
|
|
80 between expressions.
|
|
|
81 a means C is comment starter or comment ender for comment style a (default)
|
|
|
82 b means C is comment starter or comment ender for comment style b."
|
|
|
83 (interactive
|
|
|
84 ;; I really don't know why this is interactive
|
|
|
85 ;; help-form should at least be made useful whilst reading the second arg
|
|
|
86 "cSet syntax for character: \nsSet syntax for %c to: ")
|
|
|
87 (cond ((syntax-table-p table))
|
|
|
88 ((not table)
|
|
|
89 (setq table (syntax-table)))
|
|
|
90 (t
|
|
|
91 (setq table
|
|
|
92 (wrong-type-argument 'syntax-table-p table))))
|
|
|
93 (let* ((code nil)
|
|
|
94 (bflag nil)
|
|
|
95 (b3 0)
|
|
|
96 i)
|
|
|
97 (setq code (string-match (regexp-quote (char-to-string (elt spec 0)))
|
|
|
98 (syntax-designator-chars)))
|
|
|
99 (or code
|
|
|
100 (error "Invalid syntax designator: %S" spec))
|
|
|
101 (setq i 2)
|
|
|
102 (while (< i (length spec))
|
|
|
103 (let ((ch (elt spec i)))
|
|
|
104 (setq i (1+ i))
|
|
|
105 (cond ((= ch ?1)
|
|
|
106 (setq b3 (logior b3 128)))
|
|
|
107 ((= ch ?2)
|
|
|
108 (setq b3 (logior b3 32)))
|
|
|
109 ((= ch ?3)
|
|
|
110 (setq b3 (logior b3 8)))
|
|
|
111 ((= ch ?4)
|
|
|
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
|
|
|
158 ;(defun test-xm ()
|
|
|
159 ; (let ((o (copy-syntax-table))
|
|
|
160 ; (n (copy-syntax-table))
|
|
|
161 ; (codes (syntax-designator-chars))
|
|
|
162 ; (flags "12345678abp"))
|
|
|
163 ; (while t
|
|
|
164 ; (let ((spec (concat (char-to-string (elt codes
|
|
|
165 ; (random (length codes))))))
|
|
|
166 ; (if (= (random 4) 0)
|
|
|
167 ; "b"
|
|
|
168 ; " ")
|
|
|
169 ; (let* ((n (random 4))
|
|
|
170 ; (s (make-string n 0)))
|
|
|
171 ; (while (> n 0)
|
|
|
172 ; (setq n (1- n))
|
|
|
173 ; (aset s n (aref flags (random (length flags)))))
|
|
|
174 ; s))))
|
|
|
175 ; (message "%S..." spec)
|
|
|
176 ; (modify-syntax-entry ?a spec o)
|
|
|
177 ; (xmodify-syntax-entry ?a spec n)
|
|
|
178 ; (or (= (aref o ?a) (aref n ?a))
|
|
|
179 ; (error "%s"
|
|
|
180 ; (format "fucked with %S: %x %x"
|
|
|
181 ; spec (aref o ?a) (aref n ?a))))))))
|
|
|
182
|
|
|
183
|
|
|
184 (defun describe-syntax-table (table stream)
|
|
|
185 (let* (;(limit (cond ((numberp ctl-arrow) ctl-arrow)
|
|
|
186 ; ((memq ctl-arrow '(t nil)) 256)
|
|
|
187 ; (t 160)))
|
|
|
188 (describe-one #'(lambda (first last)
|
|
|
189 (let* ((tem (text-char-description first))
|
|
|
190 (pos (length tem)))
|
|
|
191 (princ tem stream)
|
|
|
192 (if (> last first)
|
|
|
193 (progn
|
|
|
194 (princ " .. " stream)
|
|
|
195 (setq tem (text-char-description last))
|
|
|
196 (princ tem stream)
|
|
|
197 (setq pos (+ pos (length tem) 4))))
|
|
|
198 (while (progn (write-char ?\ stream)
|
|
|
199 (setq pos (1+ pos))
|
|
|
200 (< pos 16))))
|
|
|
201 (describe-syntax-code (elt table first) stream))))
|
|
|
202 (let ((range 0)
|
|
|
203 (i 0)
|
|
|
204 (code (elt table 0)))
|
|
|
205 (while (cond ((= i (length table))
|
|
|
206 (funcall describe-one (1- i) (1- i))
|
|
|
207 nil)
|
|
|
208 ((eq code (elt table i))
|
|
|
209 t)
|
|
|
210 (t
|
|
|
211 (funcall describe-one range (1- i))
|
|
|
212 (setq code (elt table i)
|
|
|
213 range i)
|
|
|
214 t))
|
|
|
215 (setq i (1+ i))))))
|
|
|
216
|
|
|
217 (defun describe-syntax-code (code stream)
|
|
|
218 (let ((codes (syntax-designator-chars))
|
|
|
219 (invalid (gettext "**invalid**")) ;(empty "") ;constants
|
|
|
220 (standard-output (or stream standard-output))
|
|
|
221 ;; #### I18N3 should temporarily set buffer to output-translatable
|
|
|
222 (in #'(lambda (string)
|
|
|
223 (princ ",\n\t\t\t\t ")
|
|
|
224 (princ string))))
|
|
|
225 (if (or (not (integerp code))
|
|
|
226 (> (logand code 127) (length codes)))
|
|
|
227 (princ invalid)
|
|
|
228 (let* ((spec (elt codes (logand code 127)))
|
|
|
229 (match (logand (lsh code -8) 255))
|
|
|
230 (b3 (lsh code -16))
|
|
|
231 (start1 (/= 0 (logand b3 128))) ;logtest!
|
|
|
232 (start1b (/= 0 (logand b3 64)))
|
|
|
233 (start2 (/= 0 (logand b3 32)))
|
|
|
234 (start2b (/= 0 (logand b3 16)))
|
|
|
235 (end1 (/= 0 (logand b3 8)))
|
|
|
236 (end1b (/= 0 (logand b3 4)))
|
|
|
237 (end2 (/= 0 (logand b3 2)))
|
|
|
238 (end2b (/= 0 (logand b3 1)))
|
|
|
239 (prefix (/= 0 (logand code 128)))
|
|
|
240 (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
|
|
|
269 (if single-char-p
|
|
|
270 (princ ", style A")
|
|
|
271 (funcall in (gettext "first character of comment-start sequence A"))))
|
|
|
272 (if start2
|
|
|
273 (funcall in (gettext "second character of comment-start sequence A")))
|
|
|
274 (if end1
|
|
|
275 (if single-char-p
|
|
|
276 (princ ", style A")
|
|
|
277 (funcall in (gettext "first character of comment-end sequence A"))))
|
|
|
278 (if end2
|
|
|
279 (funcall in (gettext "second character of comment-end sequence A")))
|
|
|
280 (if start1b
|
|
|
281 (if single-char-p
|
|
|
282 (princ ", style B")
|
|
|
283 (funcall in (gettext "first character of comment-start sequence B"))))
|
|
|
284 (if start2b
|
|
|
285 (funcall in (gettext "second character of comment-start sequence B")))
|
|
|
286 (if end1b
|
|
|
287 (if single-char-p
|
|
|
288 (princ ", style B")
|
|
|
289 (funcall in (gettext "first character of comment-end sequence B"))))
|
|
|
290 (if end2b
|
|
|
291 (funcall in (gettext "second character of comment-end sequence B")))
|
|
|
292 (if prefix
|
|
|
293 (funcall in (gettext "prefix character for `backward-prefix-chars'")))))
|
|
|
294 (terpri stream)))
|
|
|
295
|
|
|
296 (defun symbol-near-point ()
|
|
|
297 "Return the first textual item to the nearest point."
|
|
|
298 (interactive)
|
|
|
299 ;alg stolen from etag.el
|
|
|
300 (save-excursion
|
|
|
301 (if (not (memq (char-syntax (preceding-char)) '(?w ?_)))
|
|
|
302 (while (not (looking-at "\\sw\\|\\s_\\|\\'"))
|
|
|
303 (forward-char 1)))
|
|
|
304 (while (looking-at "\\sw\\|\\s_")
|
|
|
305 (forward-char 1))
|
|
|
306 (if (re-search-backward "\\sw\\|\\s_" nil t)
|
|
|
307 (regexp-quote
|
|
|
308 (progn (forward-char 1)
|
|
|
309 (buffer-substring (point)
|
|
|
310 (progn (forward-sexp -1)
|
|
|
311 (while (looking-at "\\s'")
|
|
|
312 (forward-char 1))
|
|
|
313 (point)))))
|
|
|
314 nil)))
|
