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

SCM Repository

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

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 333, Tue Jun 15 03:41:26 1999 UTC revision 334, Thu Jun 17 02:43:15 1999 UTC
# Line 50  Line 50 
50           (set-syntax-table ,ost-sym)))))           (set-syntax-table ,ost-sym)))))
51  (def-edebug-spec sml-with-ist t)  (def-edebug-spec sml-with-ist t)
52    
53  (defmacro sml-move-if (f &optional c)  (defmacro sml-move-if (&rest body)
54    (let ((pt-sym (make-symbol "point"))    (let ((pt-sym (make-symbol "point"))
55          (res-sym (make-symbol "result")))          (res-sym (make-symbol "result")))
56      `(let* ((,pt-sym (point))      `(let ((,pt-sym (point))
57              (,res-sym ,f))             (,res-sym ,(cons 'progn body)))
58         (or ,(or c res-sym) (progn (goto-char ,pt-sym) nil)))))         (unless ,res-sym (goto-char ,pt-sym))
59           ,res-sym)))
60  (def-edebug-spec sml-move-if t)  (def-edebug-spec sml-move-if t)
61    
62  (defmacro sml-point-after (&rest body)  (defmacro sml-point-after (&rest body)
# Line 66  Line 67 
67    
68  ;;  ;;
69    
 (defun sml-preproc-alist (al)  
   (reduce (lambda (x al)  
             (let ((k (car x))  
                   (v (cdr x)))  
               (if (consp k)  
                   (append (mapcar (lambda (y) (cons y v)) k) al)  
                 (cons x al))))  
           al  
           :initial-value nil  
           :from-end t))  
   
70  (defvar sml-op-prec  (defvar sml-op-prec
71    (sml-preproc-alist    (sml-preproc-alist
72     '(("before" . 0)     '(("before" . 0)
# Line 87  Line 77 
77       (("/" "*" "quot" "rem" "div" "mod") . 7)))       (("/" "*" "quot" "rem" "div" "mod") . 7)))
78    "Alist of SML infix operators and their precedence.")    "Alist of SML infix operators and their precedence.")
79    
80  (defvar sml-syntax-prec  (defconst sml-syntax-prec
81    (sml-preproc-alist    (sml-preproc-alist
82     '(((";" ",") . 10)     `(((";" "," "in" "with") . 10)
83         (("=>" "d=" "=of") . (65 . 40))
84       ("|" . (47 . 30))       ("|" . (47 . 30))
85       (("case" "of" "fn") . 45)       (("case" "of" "fn") . 45)
86       (("if" "then" "else" "while" "do" "raise") . 50)       (("if" "then" "else" "while" "do" "raise") . 50)
# Line 97  Line 88 
88       ("orelse" . 70)       ("orelse" . 70)
89       ("andalso" . 80)       ("andalso" . 80)
90       ((":" ":>") . 90)       ((":" ":>") . 90)
91       ("->" . 95)))       ("->" . 95)
92         (,(cons "end" sml-begin-syms) . 10000)))
93    "Alist of pseudo-precedence of syntactic elements.")    "Alist of pseudo-precedence of syntactic elements.")
94    
95  (defun sml-op-prec (op dir)  (defun sml-op-prec (op dir)
# Line 108  Line 100 
100    (when op    (when op
101      (let ((sprec (cdr (assoc op sml-syntax-prec))))      (let ((sprec (cdr (assoc op sml-syntax-prec))))
102        (cond        (cond
103         ((consp prec) (if (eq dir 'back) (car prec) (cdr prec)))         ((consp sprec) (if (eq dir 'back) (car sprec) (cdr sprec)))
104         (prec prec)         (sprec sprec)
   
        ((or (string= "=>" op)  
             (and (string= "=" op)  
              ;; not the polymorphic equlity  
              (> (sml-point-after (re-search-backward sml-=-starter-re nil 'top))  
                 (sml-point-after (re-search-backward "=" nil 'top)))))  
         ;; depending on the direction  
         (if (eq dir 'back) 65 40))  
   
105         (t         (t
106          (let ((prec (cdr (assoc op sml-op-prec))))          (let ((prec (cdr (assoc op sml-op-prec))))
107            (when prec (+ prec 100))))))))            (when prec (+ prec 100))))))))
108    
109  ;;  ;;
110    
   
   
111  (defun sml-forward-spaces () (forward-comment 100000))  (defun sml-forward-spaces () (forward-comment 100000))
112  (defun sml-backward-spaces () (forward-comment -100000))  (defun sml-backward-spaces () (forward-comment -100000))
113    
# Line 181  Line 162 
162           (buffer-substring (point) ,pt-sym)))))           (buffer-substring (point) ,pt-sym)))))
163  (def-edebug-spec sml-move-read t)  (def-edebug-spec sml-move-read t)
164    
165    (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  (defun sml-forward-sym-1 ()  (defun sml-forward-sym-1 ()
175    (or (/= 0 (skip-syntax-forward ".'"))    (or (/= 0 (skip-syntax-forward ".'"))
176        (/= 0 (skip-syntax-forward "'w_"))))        (/= 0 (skip-syntax-forward "'w_"))))
177  (defun sml-forward-sym ()  (defun sml-forward-sym ()
178    (let ((sym (sml-move-read (sml-forward-sym-1))))    (let ((sym (sml-move-read (sml-forward-sym-1))))
179      (if (not (equal "op" sym)) sym      (cond
180         ((equal "op" sym)
181        (sml-forward-spaces)        (sml-forward-spaces)
182        (concat "op " (or (sml-move-read (sml-forward-sym-1)) "")))))        (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    
193  (defun sml-backward-sym-1 ()  (defun sml-backward-sym-1 ()
194    (or (/= 0 (skip-syntax-backward ".'"))    (or (/= 0 (skip-syntax-backward ".'"))
# Line 202  Line 202 
202          (if (equal "op" (sml-move-read (sml-backward-sym-1)))          (if (equal "op" (sml-move-read (sml-backward-sym-1)))
203              (concat "op " sym)              (concat "op " sym)
204            (goto-char point)            (goto-char point)
205            sym)))))            (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    
210    
211  (defun sml-backward-sexp (prec)  (defun sml-backward-sexp (prec)
# Line 213  Line 216 
216      (sml-backward-spaces)      (sml-backward-spaces)
217      (let* ((point (point))      (let* ((point (point))
218             (op (sml-backward-sym))             (op (sml-backward-sym))
219             (op-prec (sml-op-prec op 'back)))             (op-prec (sml-op-prec op 'back))
220               match)
221        (cond        (cond
222         ((not op)         ((not op)
223          (let ((point (point)))          (let ((point (point)))
224            (ignore-errors (backward-sexp 1))            (ignore-errors (backward-sexp 1))
225            (if (/= point (point)) t (backward-char 1) nil)))            (if (/= point (point)) t (backward-char 1) nil)))
226         ;; let...end atoms         ;; stop as soon as precedence is smaller than `prec'
227         ((or (string= "end" op)         ((and prec op-prec (>= prec op-prec)) nil)
             (and (not prec)  
                  (or (string= "in" op) (string= "with" op))))  
         (sml-find-match-backward "\\<end\\>" sml-begin-symbols-re))  
228         ;; special rules for nested constructs like if..then..else         ;; special rules for nested constructs like if..then..else
229         ((and (or (not prec) (and prec op-prec (< prec op-prec)))         ((and (or (not prec) (and prec op-prec))
230               (string-match (sml-syms-re sml-exptrail-syms) op))               (setq match (cdr (assoc op sml-close-paren))))
231          (cond          (sml-find-match-backward (concat "\\<" op "\\>") match))
232           ((or (string= "else" op) (string= "then" op))         ;; don't back over open-parens
233            (sml-find-match-backward "\\<else\\>" "\\<if\\>"))         ((assoc op sml-open-paren) nil)
          ((string= "of" op)  
           (sml-find-match-backward "\\<of\\>" "\\<case\\>"))  
          ((string= "do" op)  
           (sml-find-match-backward "\\<do\\>" "\\<while\\>"))  
          (t prec)))  
234         ;; infix ops precedence         ;; infix ops precedence
235         ((and prec op-prec) (< prec op-prec))         ((and prec op-prec) (< prec op-prec))
236         ;; [ prec = nil ]  a new operator, let's skip the sexps until the next         ;; [ prec = nil ]  a new operator, let's skip the sexps until the next

Legend:
Removed from v.333  
changed lines
  Added in v.334

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