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

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