Mercurial > hg > xemacs-beta

comparison lisp/prim/syntax.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 0293115a14e9
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
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)))