Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/sml-mode/sml-move.el
ViewVC logotype

Annotation of /sml/trunk/sml-mode/sml-move.el

Parent Directory Parent Directory | Revision Log Revision Log


Revision 319 - (view) (download)

1 : monnier 319 ;;; sml-move.el
2 :    
3 :     (defconst rcsid-sml-move "@(#)$Name$:$Id$")
4 :    
5 :     ;; Copyright (C) 1999-1999 Stefan Monnier <monnier@cs.yale.edu>
6 :     ;;
7 :     ;; This program is free software; you can redistribute it and/or modify
8 :     ;; it under the terms of the GNU General Public License as published by
9 :     ;; the Free Software Foundation; either version 2 of the License, or
10 :     ;; (at your option) any later version.
11 :     ;;
12 :     ;; This program is distributed in the hope that it will be useful,
13 :     ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14 :     ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 :     ;; GNU General Public License for more details.
16 :     ;;
17 :     ;; You should have received a copy of the GNU General Public License
18 :     ;; along with this program; if not, write to the Free Software
19 :     ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
20 :    
21 :     (require 'cl)
22 :     (require 'sml-util)
23 :     (require 'sml-defs)
24 :    
25 :     ;;
26 :    
27 :     (defsyntax sml-internal-syntax-table
28 :     '((?_ . "w")
29 :     (?' . "w")
30 :     (?. . "w")
31 :     ;; treating `~' as a word constituent is not quite right, but
32 :     ;; close enough. Think about 12.3E~2 for example. Also `~' on its
33 :     ;; own *is* a nonfix symbol.
34 :     (?~ . "w"))
35 :     "Syntax table used for internal sml-mode operation."
36 :     :copy sml-mode-syntax-table)
37 :    
38 :     (defun sml-op-prec (op dir)
39 :     "return the precedence of OP or nil if it's not an infix.
40 :     DIR should be set to BACK if you want to precedence w.r.t the left side
41 :     and to FORW for the precedence w.r.t the right side.
42 :     This assumes that we are looking-at the OP."
43 :     (cond
44 :     ((not op) nil)
45 :     ;;((or (string-match (sml-syms-re (appen
46 :     ((or (string-equal ";" op) (string-equal "," op)) 10)
47 :     ((or (string-equal "=>" op)
48 :     (and (string-equal "=" op)
49 :     ;; not the polymorphic equlity
50 :     (> (sml-point-after (re-search-backward sml-=-starter-re nil 'top))
51 :     (sml-point-after (re-search-backward "=" nil 'top)))))
52 :     ;; depending on the direction
53 :     (if (eq dir 'back) 65 40))
54 :     ((or (string-match (sml-syms-re "case" "of" "fn") op)) 45)
55 :     ((or (string-equal "|" op)) (if (eq dir 'back) 47 30))
56 :     ((or (string-match (sml-syms-re "if" "then" "else" "while" "do" "raise") op)) 50)
57 :     ((or (string-equal "handle" op)) 60)
58 :     ((or (string-equal "orelse" op)) 70)
59 :     ((or (string-equal "andalso" op)) 80)
60 :     ((or (string-equal ":" op) (string-equal ":>" op)) 90)
61 :     ((or (string-equal "->" op)) 95)
62 :     ;; standard infix ops: 10*(10 + prec) as defined in `the definition of SML'
63 :     ((or (string-equal "!" op)) nil)
64 :     ((or (string-equal "~" op)) nil)
65 :     ((or (string-equal ":=" op)) 130)
66 :     ((or (string-match "\\`[<>]?=?\\'" op)) 140)
67 :     ((or (string-equal "::" op)) 150)
68 :     ((or (string-equal "+" op) (string-equal "-" op)) 160)
69 :     ((or (string-equal "/" op) (string-equal "*" op)
70 :     (string-equal "div" op) (string-equal "mod" op)) 170)
71 :     ;; default heuristic: alphanum symbols are not infix
72 :     ((or (string-match "\\sw" op)) nil)
73 :     (t 100)))
74 :    
75 :    
76 :     (defmacro sml-with-ist (&rest r)
77 :     `(let ((sml-ost (syntax-table))
78 :     (case-fold-search nil))
79 :     (unwind-protect
80 :     (progn (set-syntax-table sml-internal-syntax-table) . ,r)
81 :     (set-syntax-table sml-ost))))
82 :     (def-edebug-spec sml-with-ist t)
83 :    
84 :     (defmacro sml-move-if (f &optional c)
85 :     `(let* ((-sml-move-if-pt (point))
86 :     (-sml-move-if-res ,f))
87 :     (or ,(or c '-sml-move-if-res) (progn (goto-char -sml-move-if-pt) nil))))
88 :     (def-edebug-spec sml-move-if t)
89 :    
90 :     (defmacro sml-move-read (&rest body)
91 :     `(let ((-sml-move-read-pt (point)))
92 :     ,@body
93 :     (when (/= (point) -sml-move-read-pt)
94 :     (buffer-substring (point) -sml-move-read-pt))))
95 :     (def-edebug-spec sml-move-read t)
96 :    
97 :     (defmacro sml-point-after (&rest body)
98 :     `(save-excursion
99 :     ,@body
100 :     (point)))
101 :     (def-edebug-spec sml-point-after t)
102 :    
103 :     ;;
104 :    
105 :     (defun sml-forward-spaces ()
106 :     (let ((parse-sexp-lookup-properties t))
107 :     (forward-comment 100000)))
108 :    
109 :    
110 :     (defun sml-looking-back-at (re)
111 :     (save-excursion
112 :     (when (= 0 (skip-syntax-backward "w")) (backward-char))
113 :     (looking-at re)))
114 :    
115 :     ;;
116 :     ;; moving forward around sexps
117 :     ;;
118 :    
119 :     (defun sml-find-match-forward (this match)
120 :     "Only works for word matches"
121 :     (let ((case-fold-search nil)
122 :     (parse-sexp-lookup-properties t)
123 :     (parse-sexp-ignore-comments t)
124 :     (level 1)
125 :     (either (concat this "\\|" match)))
126 :     (while (> level 0)
127 :     (forward-sexp 1)
128 :     (while (not (or (eobp) (sml-looking-back-at either)))
129 :     (condition-case () (forward-sexp 1) (error (forward-char 1))))
130 :     (setq level
131 :     (cond
132 :     ((sml-looking-back-at this) (1+ level))
133 :     ((sml-looking-back-at match) (1- level))
134 :     (t (error "Unbalanced")))))
135 :     t))
136 :    
137 :     ;; (defun sml-forward-sexp (&optional count strict)
138 :     ;; "Moves one sexp forward if possible, or one char else.
139 :     ;; Returns T if the move indeed moved through one sexp and NIL if not."
140 :     ;; (let ((parse-sexp-lookup-properties t)
141 :     ;; (parse-sexp-ignore-comments t))
142 :     ;; (condition-case ()
143 :     ;; (progn
144 :     ;; (forward-sexp 1)
145 :     ;; (cond
146 :     ;; ((sml-looking-back-at
147 :     ;; (if strict sml-begin-symbols-re sml-user-begin-symbols-re))
148 :     ;; (sml-find-match-forward sml-begin-symbols-re "\\<end\\>") t)
149 :     ;; ((sml-looking-back-at "\\<end\\>") nil)
150 :     ;; (t t)))
151 :     ;; (error (forward-char 1) nil))))
152 :    
153 :     ;; the terminators should be chosen more carefully:
154 :     ;; `let' isn't one while `=' may be
155 :     ;; (defun sml-forward-sexps (&optional end)
156 :     ;; (sml-forward-sexp)
157 :     ;; (while (not (sml-looking-back-at (or end (concat sml-keywords-regexp "\\|[])}|:;]"))))
158 :     ;; (sml-forward-sexp)))
159 :    
160 :     ;;
161 :     ;; now backwards
162 :     ;;
163 :    
164 :     (defun sml-backward-spaces ()
165 :     (let ((parse-sexp-lookup-properties t))
166 :     (forward-comment -100000)))
167 :    
168 :     (defun sml-find-match-backward (this match)
169 :     (let ((parse-sexp-lookup-properties t)
170 :     (parse-sexp-ignore-comments t)
171 :     (level 1)
172 :     (either (concat this "\\|" match)))
173 :     (while (> level 0)
174 :     (backward-sexp 1)
175 :     (while (not (or (bobp) (looking-at either)))
176 :     (condition-case () (backward-sexp 1) (error (backward-char 1))))
177 :     (setq level
178 :     (cond
179 :     ((looking-at this) (1+ level))
180 :     ((looking-at match) (1- level))
181 :     (t (error "Unbalanced")))))
182 :     t))
183 :    
184 :     (defun sml-forward-sym ()
185 :     (or (/= 0 (skip-syntax-forward ".'"))
186 :     (/= 0 (skip-syntax-forward "'w_"))))
187 :    
188 :     (defun sml-backward-sym ()
189 :     (or (/= 0 (skip-syntax-backward ".'"))
190 :     (/= 0 (skip-syntax-backward "'w_"))))
191 :    
192 :     (defun sml-backward-sexp (prec)
193 :     "Moves one sexp backward if possible, or one char else.
194 :     Returns T if the move indeed moved through one sexp and NIL if not."
195 :     (let ((parse-sexp-lookup-properties t)
196 :     (parse-sexp-ignore-comments t))
197 :     (sml-backward-spaces)
198 :     (let* ((point (point))
199 :     (op (sml-move-read (sml-backward-sym)))
200 :     (op-prec (sml-op-prec op 'back)))
201 :     (cond
202 :     ((not op)
203 :     (let ((point (point)))
204 :     (ignore-errors (backward-sexp 1))
205 :     (if (/= point (point)) t (backward-char 1) nil)))
206 :     ;; let...end atoms
207 :     ((or (string-equal "end" op)
208 :     (and (not prec)
209 :     (or (string-equal "in" op) (string-equal "with" op))))
210 :     (sml-find-match-backward "\\<end\\>" sml-begin-symbols-re))
211 :     ;; don't forget the `op' special keyword
212 :     ((sml-move-if (progn (sml-backward-spaces) (skip-syntax-backward "w_"))
213 :     (looking-at "\\<op\\>")) t)
214 :     ;; special rules for nested constructs like if..then..else
215 :     ((and (or (not prec) (and prec op-prec (< prec op-prec)))
216 :     (string-match (sml-syms-re sml-exptrail-syms) op))
217 :     (cond
218 :     ((or (string-equal "else" op) (string-equal "then" op))
219 :     (sml-find-match-backward "\\<else\\>" "\\<if\\>"))
220 :     ((string-equal "of" op)
221 :     (sml-find-match-backward "\\<of\\>" "\\<case\\>"))
222 :     ((string-equal "do" op)
223 :     (sml-find-match-backward "\\<do\\>" "\\<while\\>"))
224 :     (t prec)))
225 :     ;; infix ops precedence
226 :     ((and prec op-prec) (< prec op-prec))
227 :     ;; [ prec = nil ] a new operator, let's skip the sexps until the next
228 :     (op-prec (while (sml-move-if (sml-backward-sexp op-prec))) t)
229 :     ;; special symbols indicating we're getting out of a nesting level
230 :     ((string-match sml-sexp-head-symbols-re op) nil)
231 :     ;; if the op was not alphanum, then we still have to do the backward-sexp
232 :     ;; this reproduces the usual backward-sexp, but it might be bogus
233 :     ;; in this case since !@$% is a perfectly fine symbol
234 :     (t t))))) ;(or (string-match "\\sw" op) (sml-backward-sexp prec))
235 :    
236 :     (defun sml-forward-sexp (prec)
237 :     "Moves one sexp forward if possible, or one char else.
238 :     Returns T if the move indeed moved through one sexp and NIL if not."
239 :     (let ((parse-sexp-lookup-properties t)
240 :     (parse-sexp-ignore-comments t))
241 :     (sml-forward-spaces)
242 :     (let* ((point (point))
243 :     (op (sml-move-read (sml-forward-sym)))
244 :     (op-prec (sml-op-prec op 'forw)))
245 :     (cond
246 :     ((not op)
247 :     (let ((point (point)))
248 :     (ignore-errors (forward-sexp 1))
249 :     (if (/= point (point)) t (forward-char 1) nil)))
250 :     ;; let...end atoms
251 :     ((or (string-match sml-begin-symbols-re op)
252 :     (and (not prec)
253 :     (or (string-equal "in" op) (string-equal "with" op))))
254 :     (sml-find-match-forward sml-begin-symbols-re "\\<end\\>"))
255 :     ;; don't forget the `op' special keyword
256 :     ((string-equal "op" op) (sml-forward-sym))
257 :     ;; infix ops precedence
258 :     ((and prec op-prec) (< prec op-prec))
259 :     ;; [ prec = nil ] if...then...else
260 :     ;; ((or (string-equal "else" op) (string-equal "then" op))
261 :     ;; (sml-find-match-backward "\\<else\\>" "\\<if\\>"))
262 :     ;; [ prec = nil ] case...of
263 :     ;; ((string-equal "of" op)
264 :     ;; (sml-find-match-backward "\\<of\\>" "\\<case\\>"))
265 :     ;; [ prec = nil ] while...do
266 :     ;; ((string-equal "do" op)
267 :     ;; (sml-find-match-backward "\\<do\\>" "\\<while\\>"))
268 :     ;; [ prec = nil ] a new operator, let's skip the sexps until the next
269 :     (op-prec (while (sml-move-if (sml-forward-sexp op-prec))) t)
270 :     ;; special symbols indicating we're getting out of a nesting level
271 :     ((string-match sml-sexp-head-symbols-re op) nil)
272 :     ;; if the op was not alphanum, then we still have to do the backward-sexp
273 :     ;; this reproduces the usual backward-sexp, but it might be bogus
274 :     ;; in this case since !@$% is a perfectly fine symbol
275 :     (t t))))) ;(or (string-match "\\sw" op) (sml-backward-sexp prec))
276 :    
277 :     (defun sml-in-word-p ()
278 :     (and (eq ?w (char-syntax (char-before)))
279 :     (eq ?w (char-syntax (char-after)))))
280 :    
281 :     (defun sml-user-backward-sexp (&optional count)
282 :     "Like `backward-sexp' but tailored to the SML syntax."
283 :     (interactive "p")
284 :     (unless count (setq count 1))
285 :     (sml-with-ist
286 :     (let ((point (point)))
287 :     (if (< count 0) (sml-user-forward-sexp (- count))
288 :     (when (sml-in-word-p) (forward-word 1))
289 :     (dotimes (i count)
290 :     (unless (sml-backward-sexp nil)
291 :     (goto-char point)
292 :     (error "Containing expression ends prematurely")))))))
293 :    
294 :     (defun sml-user-forward-sexp (&optional count)
295 :     "Like `forward-sexp' but tailored to the SML syntax."
296 :     (interactive "p")
297 :     (unless count (setq count 1))
298 :     (sml-with-ist
299 :     (let ((point (point)))
300 :     (if (< count 0) (sml-user-backward-sexp (- count))
301 :     (when (sml-in-word-p) (backward-word 1))
302 :     (dotimes (i count)
303 :     (unless (sml-forward-sexp nil)
304 :     (goto-char point)
305 :     (error "Containing expression ends prematurely")))))))
306 :    
307 :     ;;(defun sml-forward-thing ()
308 :     ;; (if (= ?w (char-syntax (char-after))) (forward-word 1) (forward-char 1)))
309 :    
310 :     (defun sml-backward-arg () (sml-backward-sexp 1000))
311 :     (defun sml-forward-arg () (sml-forward-sexp 1000))
312 :    
313 :     ;; (defun sml-backward-arg ()
314 :     ;; "Moves one sexp backward (and return T) if it is an argument."
315 :     ;; (let* ((point (point))
316 :     ;; (argp (and (sml-backward-sexp t)
317 :     ;; (not (looking-at sml-not-arg-re))
318 :     ;; (save-excursion
319 :     ;; (sml-forward-sexp 1 t)
320 :     ;; (sml-forward-spaces)
321 :     ;; (>= (point) point)))))
322 :     ;; (unless argp (goto-char point))
323 :     ;; argp))
324 :    
325 :     ;; (defun sml-backward-sexps (&optional end)
326 :     ;; (sml-backward-spaces)
327 :     ;; (let ((eos (point)))
328 :     ;; (sml-backward-sexp t)
329 :     ;; (while (not (save-restriction
330 :     ;; (narrow-to-region (point) eos)
331 :     ;; (looking-at (or end sml-keywords-regexp))))
332 :     ;; (sml-backward-spaces)
333 :     ;; (setq eos (point))
334 :     ;; (sml-backward-sexp t))
335 :     ;; (if (looking-at "\\sw")
336 :     ;; (forward-word 1)
337 :     ;; (forward-char))
338 :     ;; (sml-forward-spaces)))
339 :    
340 :     ;; (defun sml-up-list ()
341 :     ;; (save-excursion
342 :     ;; (condition-case ()
343 :     ;; (progn
344 :     ;; (up-list 1)
345 :     ;; (point))
346 :     ;; (error 0))))
347 :    
348 :     ;;
349 :     (provide 'sml-move)

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0