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-mode/releases/release-110.32/sml-move.el
ViewVC logotype

Annotation of /sml-mode/releases/release-110.32/sml-move.el

Parent Directory Parent Directory | Revision Log Revision Log


Revision 343 - (view) (download)
Original Path: sml/trunk/sml-mode/sml-move.el

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

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