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 762 - (view) (download)
Original Path: sml/releases/release-110.32/sml-mode/sml-move.el

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

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