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

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

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

revision 332, Tue Jun 15 00:51:38 1999 UTC revision 333, Tue Jun 15 03:41:26 1999 UTC
# Line 42  Line 42 
42  (defmacro sml-with-ist (&rest r)  (defmacro sml-with-ist (&rest r)
43    (let ((ost-sym (make-symbol "oldtable")))    (let ((ost-sym (make-symbol "oldtable")))
44      `(let ((,ost-sym (syntax-table))      `(let ((,ost-sym (syntax-table))
45             (case-fold-search nil))             (case-fold-search nil)
46               (parse-sexp-lookup-properties t)
47               (parse-sexp-ignore-comments t))
48         (unwind-protect         (unwind-protect
49             (progn (set-syntax-table sml-internal-syntax-table) . ,r)             (progn (set-syntax-table sml-internal-syntax-table) . ,r)
50           (set-syntax-table ,ost-sym)))))           (set-syntax-table ,ost-sym)))))
# Line 56  Line 58 
58         (or ,(or c res-sym) (progn (goto-char ,pt-sym) nil)))))         (or ,(or c res-sym) (progn (goto-char ,pt-sym) nil)))))
59  (def-edebug-spec sml-move-if t)  (def-edebug-spec sml-move-if t)
60    
 (defmacro sml-move-read (&rest body)  
   (let ((pt-sym (make-symbol "point")))  
     `(let ((,pt-sym (point)))  
        ,@body  
        (when (/= (point) ,pt-sym)  
          (buffer-substring (point) ,pt-sym)))))  
 (def-edebug-spec sml-move-read t)  
   
61  (defmacro sml-point-after (&rest body)  (defmacro sml-point-after (&rest body)
62    `(save-excursion    `(save-excursion
63       ,@body       ,@body
# Line 72  Line 66 
66    
67  ;;  ;;
68    
69    (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  (defun sml-op-prec (op dir)  (defun sml-op-prec (op dir)
104    "return the precedence of OP or nil if it's not an infix.    "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  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.      and to FORW for the precedence w.r.t the right side.
107  This assumes that we are looking-at the OP."  This assumes that we are looking-at the OP."
108      (when op
109        (let ((sprec (cdr (assoc op sml-syntax-prec))))
110    (cond    (cond
111     ((not op) nil)         ((consp prec) (if (eq dir 'back) (car prec) (cdr prec)))
112     ;;((or (string-match (sml-syms-re (appen         (prec prec)
113     ((or (string= ";" op) (string= "," op)) 10)  
114     ((or (string= "=>" op)     ((or (string= "=>" op)
115          (and (string= "=" op)          (and (string= "=" op)
116               ;; not the polymorphic equlity               ;; not the polymorphic equlity
# Line 88  Line 118 
118                  (sml-point-after (re-search-backward "=" nil 'top)))))                  (sml-point-after (re-search-backward "=" nil 'top)))))
119      ;; depending on the direction      ;; depending on the direction
120      (if (eq dir 'back) 65 40))      (if (eq dir 'back) 65 40))
121     ((or (string-match (sml-syms-re "case" "of" "fn") op)) 45)  
122     ((or (string= "|" op)) (if (eq dir 'back) 47 30))         (t
123     ((or (string-match (sml-syms-re "if" "then" "else" "while" "do" "raise") op)) 50)          (let ((prec (cdr (assoc op sml-op-prec))))
124     ((or (string= "handle" op)) 60)            (when prec (+ prec 100))))))))
    ((or (string= "orelse" op)) 70)  
    ((or (string= "andalso" op)) 80)  
    ((or (string= ":" op) (string= ":>" op)) 90)  
    ((or (string= "->" op)) 95)  
    ;; standard infix ops: 10*(10 + prec) as defined in `the definition of SML'  
    ;;((or (string= "!" op)) nil)  
    ;;((or (string= "~" op)) nil)  
    ((or (string= "before" op)) 100)  
    ((or (string= ":=" op) (string= "o" op)) 130)  
    ((or (string= ">" op) (string= ">=" op) (string= "<>" op)  
         (string= "<" op) (string= "<=" op) (string= "=" op)) 140)  
    ((or (string= "::" op) (string= "@" op)) 150)  
    ((or (string= "+" op) (string= "-" op) (string= "^" op)) 160)  
    ((or (string= "/" op) (string= "*" op)  
         (string= "quot" op) (string= "rem" op)  
         (string= "div" op) (string= "mod" op)) 170)  
    ;; default heuristic: alphanum symbols are not infix  
    ;;((or (string-match "\\sw" op)) nil)  
    ;;(t 100)  
    (t nil)  
    ))  
125    
126  ;;  ;;
127    
 (defun sml-forward-spaces ()  
   (let ((parse-sexp-lookup-properties t))  
     (forward-comment 100000)))  
128    
129    
130  (defun sml-looking-back-at (re)  (defun sml-forward-spaces () (forward-comment 100000))
131    (save-excursion  (defun sml-backward-spaces () (forward-comment -100000))
132      (when (= 0 (skip-syntax-backward "w")) (backward-char))  
     (looking-at re)))  
133    
134  ;;  ;;
135  ;; moving forward around sexps  ;; moving forward around matching symbols
136  ;;  ;;
137    
138    (defun sml-looking-back-at (re)
139      (save-excursion
140        (when (= 0 (skip-syntax-backward "w_")) (backward-char))
141        (looking-at re)))
142    
143  (defun sml-find-match-forward (this match)  (defun sml-find-match-forward (this match)
144    "Only works for word matches"    "Only works for word matches"
145    (let ((case-fold-search nil)    (let ((level 1)
         (parse-sexp-lookup-properties t)  
         (parse-sexp-ignore-comments t)  
         (level 1)  
146          (either (concat this "\\|" match)))          (either (concat this "\\|" match)))
147      (while (> level 0)      (while (> level 0)
148        (forward-sexp 1)        (forward-sexp 1)
# Line 148  Line 155 
155               (t (error "Unbalanced")))))               (t (error "Unbalanced")))))
156      t))      t))
157    
 ;;  
 ;; now backwards  
 ;;  
   
 (defun sml-backward-spaces ()  
   (let ((parse-sexp-lookup-properties t))  
     (forward-comment -100000)))  
   
158  (defun sml-find-match-backward (this match)  (defun sml-find-match-backward (this match)
159    (let ((parse-sexp-lookup-properties t)    (let ((level 1)
         (parse-sexp-ignore-comments t)  
         (level 1)  
160          (either (concat this "\\|" match)))          (either (concat this "\\|" match)))
161      (while (> level 0)      (while (> level 0)
162        (backward-sexp 1)        (backward-sexp 1)
# Line 172  Line 169 
169               (t (error "Unbalanced")))))               (t (error "Unbalanced")))))
170      t))      t))
171    
172  (defun sml-forward-sym ()  ;;;
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    (or (/= 0 (skip-syntax-forward ".'"))    (or (/= 0 (skip-syntax-forward ".'"))
186        (/= 0 (skip-syntax-forward "'w_"))))        (/= 0 (skip-syntax-forward "'w_"))))
187    (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    
193  (defun sml-backward-sym ()  (defun sml-backward-sym-1 ()
194    (or (/= 0 (skip-syntax-backward ".'"))    (or (/= 0 (skip-syntax-backward ".'"))
195        (/= 0 (skip-syntax-backward "'w_"))))        (/= 0 (skip-syntax-backward "'w_"))))
196    (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    
208  (defun sml-backward-sexp (prec)  (defun sml-backward-sexp (prec)
209    "Moves one sexp backward if possible, or one char else.    "Moves one sexp backward if possible, or one char else.
# Line 187  Line 212 
212          (parse-sexp-ignore-comments t))          (parse-sexp-ignore-comments t))
213      (sml-backward-spaces)      (sml-backward-spaces)
214      (let* ((point (point))      (let* ((point (point))
215             (op (sml-move-read (sml-backward-sym)))             (op (sml-backward-sym))
216             (op-prec (sml-op-prec op 'back)))             (op-prec (sml-op-prec op 'back)))
217        (cond        (cond
218         ((not op)         ((not op)
# Line 199  Line 224 
224              (and (not prec)              (and (not prec)
225                   (or (string= "in" op) (string= "with" op))))                   (or (string= "in" op) (string= "with" op))))
226          (sml-find-match-backward "\\<end\\>" sml-begin-symbols-re))          (sml-find-match-backward "\\<end\\>" sml-begin-symbols-re))
        ;; don't forget the `op' special keyword  
        ((sml-move-if (progn (sml-backward-spaces) (skip-syntax-backward "w_"))  
                      (looking-at "\\<op\\>")) t)  
227         ;; special rules for nested constructs like if..then..else         ;; special rules for nested constructs like if..then..else
228         ((and (or (not prec) (and prec op-prec (< prec op-prec)))         ((and (or (not prec) (and prec op-prec (< prec op-prec)))
229               (string-match (sml-syms-re sml-exptrail-syms) op))               (string-match (sml-syms-re sml-exptrail-syms) op))
# Line 231  Line 253 
253          (parse-sexp-ignore-comments t))          (parse-sexp-ignore-comments t))
254      (sml-forward-spaces)      (sml-forward-spaces)
255      (let* ((point (point))      (let* ((point (point))
256             (op (sml-move-read (sml-forward-sym)))             (op (sml-forward-sym))
257             (op-prec (sml-op-prec op 'forw)))             (op-prec (sml-op-prec op 'forw)))
258        (cond        (cond
259         ((not op)         ((not op)
# Line 243  Line 265 
265              (and (not prec)              (and (not prec)
266                   (or (string= "in" op) (string= "with" op))))                   (or (string= "in" op) (string= "with" op))))
267          (sml-find-match-forward sml-begin-symbols-re "\\<end\\>"))          (sml-find-match-forward sml-begin-symbols-re "\\<end\\>"))
        ;; don't forget the `op' special keyword  
        ((string= "op" op) (sml-forward-sym))  
268         ;; infix ops precedence         ;; infix ops precedence
269         ((and prec op-prec) (< prec op-prec))         ((and prec op-prec) (< prec op-prec))
270         ;; [ prec = nil ]  if...then...else         ;; [ prec = nil ]  if...then...else

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

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