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 332 - (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 : monnier 332 ;;;
39 :     ;;; various macros
40 :     ;;;
41 :    
42 :     (defmacro sml-with-ist (&rest r)
43 :     (let ((ost-sym (make-symbol "oldtable")))
44 :     `(let ((,ost-sym (syntax-table))
45 :     (case-fold-search nil))
46 :     (unwind-protect
47 :     (progn (set-syntax-table sml-internal-syntax-table) . ,r)
48 :     (set-syntax-table ,ost-sym)))))
49 :     (def-edebug-spec sml-with-ist t)
50 :    
51 :     (defmacro sml-move-if (f &optional c)
52 :     (let ((pt-sym (make-symbol "point"))
53 :     (res-sym (make-symbol "result")))
54 :     `(let* ((,pt-sym (point))
55 :     (,res-sym ,f))
56 :     (or ,(or c res-sym) (progn (goto-char ,pt-sym) nil)))))
57 :     (def-edebug-spec sml-move-if t)
58 :    
59 :     (defmacro sml-move-read (&rest body)
60 :     (let ((pt-sym (make-symbol "point")))
61 :     `(let ((,pt-sym (point)))
62 :     ,@body
63 :     (when (/= (point) ,pt-sym)
64 :     (buffer-substring (point) ,pt-sym)))))
65 :     (def-edebug-spec sml-move-read t)
66 :    
67 :     (defmacro sml-point-after (&rest body)
68 :     `(save-excursion
69 :     ,@body
70 :     (point)))
71 :     (def-edebug-spec sml-point-after t)
72 :    
73 :     ;;
74 :    
75 : monnier 319 (defun sml-op-prec (op dir)
76 :     "return the precedence of OP or nil if it's not an infix.
77 :     DIR should be set to BACK if you want to precedence w.r.t the left side
78 :     and to FORW for the precedence w.r.t the right side.
79 :     This assumes that we are looking-at the OP."
80 :     (cond
81 :     ((not op) nil)
82 :     ;;((or (string-match (sml-syms-re (appen
83 : monnier 332 ((or (string= ";" op) (string= "," op)) 10)
84 :     ((or (string= "=>" op)
85 :     (and (string= "=" op)
86 : monnier 319 ;; not the polymorphic equlity
87 :     (> (sml-point-after (re-search-backward sml-=-starter-re nil 'top))
88 :     (sml-point-after (re-search-backward "=" nil 'top)))))
89 :     ;; depending on the direction
90 :     (if (eq dir 'back) 65 40))
91 :     ((or (string-match (sml-syms-re "case" "of" "fn") op)) 45)
92 : monnier 332 ((or (string= "|" op)) (if (eq dir 'back) 47 30))
93 : monnier 319 ((or (string-match (sml-syms-re "if" "then" "else" "while" "do" "raise") op)) 50)
94 : monnier 332 ((or (string= "handle" op)) 60)
95 :     ((or (string= "orelse" op)) 70)
96 :     ((or (string= "andalso" op)) 80)
97 :     ((or (string= ":" op) (string= ":>" op)) 90)
98 :     ((or (string= "->" op)) 95)
99 : monnier 319 ;; standard infix ops: 10*(10 + prec) as defined in `the definition of SML'
100 : monnier 332 ;;((or (string= "!" op)) nil)
101 :     ;;((or (string= "~" op)) nil)
102 :     ((or (string= "before" op)) 100)
103 :     ((or (string= ":=" op) (string= "o" op)) 130)
104 :     ((or (string= ">" op) (string= ">=" op) (string= "<>" op)
105 :     (string= "<" op) (string= "<=" op) (string= "=" op)) 140)
106 :     ((or (string= "::" op) (string= "@" op)) 150)
107 :     ((or (string= "+" op) (string= "-" op) (string= "^" op)) 160)
108 :     ((or (string= "/" op) (string= "*" op)
109 :     (string= "quot" op) (string= "rem" op)
110 :     (string= "div" op) (string= "mod" op)) 170)
111 : monnier 319 ;; default heuristic: alphanum symbols are not infix
112 : monnier 332 ;;((or (string-match "\\sw" op)) nil)
113 :     ;;(t 100)
114 :     (t nil)
115 :     ))
116 : monnier 319
117 :     ;;
118 :    
119 :     (defun sml-forward-spaces ()
120 :     (let ((parse-sexp-lookup-properties t))
121 :     (forward-comment 100000)))
122 :    
123 :    
124 :     (defun sml-looking-back-at (re)
125 :     (save-excursion
126 :     (when (= 0 (skip-syntax-backward "w")) (backward-char))
127 :     (looking-at re)))
128 :    
129 :     ;;
130 :     ;; moving forward around sexps
131 :     ;;
132 :    
133 :     (defun sml-find-match-forward (this match)
134 :     "Only works for word matches"
135 :     (let ((case-fold-search nil)
136 :     (parse-sexp-lookup-properties t)
137 :     (parse-sexp-ignore-comments t)
138 :     (level 1)
139 :     (either (concat this "\\|" match)))
140 :     (while (> level 0)
141 :     (forward-sexp 1)
142 :     (while (not (or (eobp) (sml-looking-back-at either)))
143 :     (condition-case () (forward-sexp 1) (error (forward-char 1))))
144 :     (setq level
145 :     (cond
146 :     ((sml-looking-back-at this) (1+ level))
147 :     ((sml-looking-back-at match) (1- level))
148 :     (t (error "Unbalanced")))))
149 :     t))
150 :    
151 :     ;;
152 :     ;; now backwards
153 :     ;;
154 :    
155 :     (defun sml-backward-spaces ()
156 :     (let ((parse-sexp-lookup-properties t))
157 :     (forward-comment -100000)))
158 :    
159 :     (defun sml-find-match-backward (this match)
160 :     (let ((parse-sexp-lookup-properties t)
161 :     (parse-sexp-ignore-comments t)
162 :     (level 1)
163 :     (either (concat this "\\|" match)))
164 :     (while (> level 0)
165 :     (backward-sexp 1)
166 :     (while (not (or (bobp) (looking-at either)))
167 :     (condition-case () (backward-sexp 1) (error (backward-char 1))))
168 :     (setq level
169 :     (cond
170 :     ((looking-at this) (1+ level))
171 :     ((looking-at match) (1- level))
172 :     (t (error "Unbalanced")))))
173 :     t))
174 :    
175 :     (defun sml-forward-sym ()
176 :     (or (/= 0 (skip-syntax-forward ".'"))
177 :     (/= 0 (skip-syntax-forward "'w_"))))
178 :    
179 :     (defun sml-backward-sym ()
180 :     (or (/= 0 (skip-syntax-backward ".'"))
181 :     (/= 0 (skip-syntax-backward "'w_"))))
182 :    
183 :     (defun sml-backward-sexp (prec)
184 :     "Moves one sexp backward if possible, or one char else.
185 :     Returns T if the move indeed moved through one sexp and NIL if not."
186 :     (let ((parse-sexp-lookup-properties t)
187 :     (parse-sexp-ignore-comments t))
188 :     (sml-backward-spaces)
189 :     (let* ((point (point))
190 :     (op (sml-move-read (sml-backward-sym)))
191 :     (op-prec (sml-op-prec op 'back)))
192 :     (cond
193 :     ((not op)
194 :     (let ((point (point)))
195 :     (ignore-errors (backward-sexp 1))
196 :     (if (/= point (point)) t (backward-char 1) nil)))
197 :     ;; let...end atoms
198 : monnier 332 ((or (string= "end" op)
199 : monnier 319 (and (not prec)
200 : monnier 332 (or (string= "in" op) (string= "with" op))))
201 : monnier 319 (sml-find-match-backward "\\<end\\>" sml-begin-symbols-re))
202 :     ;; don't forget the `op' special keyword
203 :     ((sml-move-if (progn (sml-backward-spaces) (skip-syntax-backward "w_"))
204 :     (looking-at "\\<op\\>")) t)
205 :     ;; special rules for nested constructs like if..then..else
206 :     ((and (or (not prec) (and prec op-prec (< prec op-prec)))
207 :     (string-match (sml-syms-re sml-exptrail-syms) op))
208 :     (cond
209 : monnier 332 ((or (string= "else" op) (string= "then" op))
210 : monnier 319 (sml-find-match-backward "\\<else\\>" "\\<if\\>"))
211 : monnier 332 ((string= "of" op)
212 : monnier 319 (sml-find-match-backward "\\<of\\>" "\\<case\\>"))
213 : monnier 332 ((string= "do" op)
214 : monnier 319 (sml-find-match-backward "\\<do\\>" "\\<while\\>"))
215 :     (t prec)))
216 :     ;; infix ops precedence
217 :     ((and prec op-prec) (< prec op-prec))
218 :     ;; [ prec = nil ] a new operator, let's skip the sexps until the next
219 :     (op-prec (while (sml-move-if (sml-backward-sexp op-prec))) t)
220 :     ;; special symbols indicating we're getting out of a nesting level
221 :     ((string-match sml-sexp-head-symbols-re op) nil)
222 :     ;; if the op was not alphanum, then we still have to do the backward-sexp
223 :     ;; this reproduces the usual backward-sexp, but it might be bogus
224 :     ;; in this case since !@$% is a perfectly fine symbol
225 :     (t t))))) ;(or (string-match "\\sw" op) (sml-backward-sexp prec))
226 :    
227 :     (defun sml-forward-sexp (prec)
228 :     "Moves one sexp forward if possible, or one char else.
229 :     Returns T if the move indeed moved through one sexp and NIL if not."
230 :     (let ((parse-sexp-lookup-properties t)
231 :     (parse-sexp-ignore-comments t))
232 :     (sml-forward-spaces)
233 :     (let* ((point (point))
234 :     (op (sml-move-read (sml-forward-sym)))
235 :     (op-prec (sml-op-prec op 'forw)))
236 :     (cond
237 :     ((not op)
238 :     (let ((point (point)))
239 :     (ignore-errors (forward-sexp 1))
240 :     (if (/= point (point)) t (forward-char 1) nil)))
241 :     ;; let...end atoms
242 :     ((or (string-match sml-begin-symbols-re op)
243 :     (and (not prec)
244 : monnier 332 (or (string= "in" op) (string= "with" op))))
245 : monnier 319 (sml-find-match-forward sml-begin-symbols-re "\\<end\\>"))
246 :     ;; don't forget the `op' special keyword
247 : monnier 332 ((string= "op" op) (sml-forward-sym))
248 : monnier 319 ;; infix ops precedence
249 :     ((and prec op-prec) (< prec op-prec))
250 :     ;; [ prec = nil ] if...then...else
251 : monnier 332 ;; ((or (string= "else" op) (string= "then" op))
252 : monnier 319 ;; (sml-find-match-backward "\\<else\\>" "\\<if\\>"))
253 :     ;; [ prec = nil ] case...of
254 : monnier 332 ;; ((string= "of" op)
255 : monnier 319 ;; (sml-find-match-backward "\\<of\\>" "\\<case\\>"))
256 :     ;; [ prec = nil ] while...do
257 : monnier 332 ;; ((string= "do" op)
258 : monnier 319 ;; (sml-find-match-backward "\\<do\\>" "\\<while\\>"))
259 :     ;; [ prec = nil ] a new operator, let's skip the sexps until the next
260 :     (op-prec (while (sml-move-if (sml-forward-sexp op-prec))) t)
261 :     ;; special symbols indicating we're getting out of a nesting level
262 :     ((string-match sml-sexp-head-symbols-re op) nil)
263 :     ;; if the op was not alphanum, then we still have to do the backward-sexp
264 :     ;; this reproduces the usual backward-sexp, but it might be bogus
265 :     ;; in this case since !@$% is a perfectly fine symbol
266 :     (t t))))) ;(or (string-match "\\sw" op) (sml-backward-sexp prec))
267 :    
268 :     (defun sml-in-word-p ()
269 : monnier 332 (and (eq ?w (char-syntax (or (char-before) ? )))
270 :     (eq ?w (char-syntax (or (char-after) ? )))))
271 : monnier 319
272 :     (defun sml-user-backward-sexp (&optional count)
273 :     "Like `backward-sexp' but tailored to the SML syntax."
274 :     (interactive "p")
275 :     (unless count (setq count 1))
276 :     (sml-with-ist
277 :     (let ((point (point)))
278 :     (if (< count 0) (sml-user-forward-sexp (- count))
279 :     (when (sml-in-word-p) (forward-word 1))
280 :     (dotimes (i count)
281 :     (unless (sml-backward-sexp nil)
282 :     (goto-char point)
283 :     (error "Containing expression ends prematurely")))))))
284 :    
285 :     (defun sml-user-forward-sexp (&optional count)
286 :     "Like `forward-sexp' but tailored to the SML syntax."
287 :     (interactive "p")
288 :     (unless count (setq count 1))
289 :     (sml-with-ist
290 :     (let ((point (point)))
291 :     (if (< count 0) (sml-user-backward-sexp (- count))
292 :     (when (sml-in-word-p) (backward-word 1))
293 :     (dotimes (i count)
294 :     (unless (sml-forward-sexp nil)
295 :     (goto-char point)
296 :     (error "Containing expression ends prematurely")))))))
297 :    
298 :     ;;(defun sml-forward-thing ()
299 :     ;; (if (= ?w (char-syntax (char-after))) (forward-word 1) (forward-char 1)))
300 :    
301 :     (defun sml-backward-arg () (sml-backward-sexp 1000))
302 :     (defun sml-forward-arg () (sml-forward-sexp 1000))
303 :    
304 :     ;;
305 :     (provide 'sml-move)

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