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 319, Mon Jun 7 22:47:00 1999 UTC revision 332, Tue Jun 15 00:51:38 1999 UTC
# Line 35  Line 35 
35    "Syntax table used for internal sml-mode operation."    "Syntax table used for internal sml-mode operation."
36    :copy sml-mode-syntax-table)    :copy sml-mode-syntax-table)
37    
38  (defun sml-op-prec (op dir)  ;;;
39    "return the precedence of OP or nil if it's not an infix.  ;;; various macros
40  DIR should be set to BACK if you want to precedence w.r.t the left side  ;;;
     and to FORW for the precedence w.r.t the right side.  
 This assumes that we are looking-at the OP."  
   (cond  
    ((not op) nil)  
    ;;((or (string-match (sml-syms-re (appen  
    ((or (string-equal ";" op) (string-equal "," op)) 10)  
    ((or (string-equal "=>" op)  
         (and (string-equal "=" 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))  
    ((or (string-match (sml-syms-re "case" "of" "fn") op)) 45)  
    ((or (string-equal "|" op)) (if (eq dir 'back) 47 30))  
    ((or (string-match (sml-syms-re "if" "then" "else" "while" "do" "raise") op)) 50)  
    ((or (string-equal "handle" op)) 60)  
    ((or (string-equal "orelse" op)) 70)  
    ((or (string-equal "andalso" op)) 80)  
    ((or (string-equal ":" op) (string-equal ":>" op)) 90)  
    ((or (string-equal "->" op)) 95)  
    ;; standard infix ops: 10*(10 + prec) as defined in `the definition of SML'  
    ((or (string-equal "!" op)) nil)  
    ((or (string-equal "~" op)) nil)  
    ((or (string-equal ":=" op)) 130)  
    ((or (string-match "\\`[<>]?=?\\'" op)) 140)  
    ((or (string-equal "::" op)) 150)  
    ((or (string-equal "+" op) (string-equal "-" op)) 160)  
    ((or (string-equal "/" op) (string-equal "*" op)  
         (string-equal "div" op) (string-equal "mod" op)) 170)  
    ;; default heuristic: alphanum symbols are not infix  
    ((or (string-match "\\sw" op)) nil)  
    (t 100)))  
   
41    
42  (defmacro sml-with-ist (&rest r)  (defmacro sml-with-ist (&rest r)
43    `(let ((sml-ost (syntax-table))    (let ((ost-sym (make-symbol "oldtable")))
44        `(let ((,ost-sym (syntax-table))
45           (case-fold-search nil))           (case-fold-search nil))
46       (unwind-protect       (unwind-protect
47           (progn (set-syntax-table sml-internal-syntax-table) . ,r)           (progn (set-syntax-table sml-internal-syntax-table) . ,r)
48         (set-syntax-table sml-ost))))           (set-syntax-table ,ost-sym)))))
49  (def-edebug-spec sml-with-ist t)  (def-edebug-spec sml-with-ist t)
50    
51  (defmacro sml-move-if (f &optional c)  (defmacro sml-move-if (f &optional c)
52    `(let* ((-sml-move-if-pt (point))    (let ((pt-sym (make-symbol "point"))
53            (-sml-move-if-res ,f))          (res-sym (make-symbol "result")))
54       (or ,(or c '-sml-move-if-res) (progn (goto-char -sml-move-if-pt) nil))))      `(let* ((,pt-sym (point))
55                (,res-sym ,f))
56           (or ,(or c res-sym) (progn (goto-char ,pt-sym) nil)))))
57  (def-edebug-spec sml-move-if t)  (def-edebug-spec sml-move-if t)
58    
59  (defmacro sml-move-read (&rest body)  (defmacro sml-move-read (&rest body)
60    `(let ((-sml-move-read-pt (point)))    (let ((pt-sym (make-symbol "point")))
61        `(let ((,pt-sym (point)))
62       ,@body       ,@body
63       (when (/= (point) -sml-move-read-pt)         (when (/= (point) ,pt-sym)
64         (buffer-substring (point) -sml-move-read-pt))))           (buffer-substring (point) ,pt-sym)))))
65  (def-edebug-spec sml-move-read t)  (def-edebug-spec sml-move-read t)
66    
67  (defmacro sml-point-after (&rest body)  (defmacro sml-point-after (&rest body)
# Line 102  Line 72 
72    
73  ;;  ;;
74    
75    (defun sml-op-prec (op dir)
76      "return the precedence of OP or nil if it's not an infix.
77    DIR should be set to BACK if you want to precedence w.r.t the left side
78        and to FORW for the precedence w.r.t the right side.
79    This assumes that we are looking-at the OP."
80      (cond
81       ((not op) nil)
82       ;;((or (string-match (sml-syms-re (appen
83       ((or (string= ";" op) (string= "," op)) 10)
84       ((or (string= "=>" op)
85            (and (string= "=" op)
86                 ;; not the polymorphic equlity
87                 (> (sml-point-after (re-search-backward sml-=-starter-re nil 'top))
88                    (sml-point-after (re-search-backward "=" nil 'top)))))
89        ;; depending on the direction
90        (if (eq dir 'back) 65 40))
91       ((or (string-match (sml-syms-re "case" "of" "fn") op)) 45)
92       ((or (string= "|" op)) (if (eq dir 'back) 47 30))
93       ((or (string-match (sml-syms-re "if" "then" "else" "while" "do" "raise") op)) 50)
94       ((or (string= "handle" op)) 60)
95       ((or (string= "orelse" op)) 70)
96       ((or (string= "andalso" op)) 80)
97       ((or (string= ":" op) (string= ":>" op)) 90)
98       ((or (string= "->" op)) 95)
99       ;; standard infix ops: 10*(10 + prec) as defined in `the definition of SML'
100       ;;((or (string= "!" op)) nil)
101       ;;((or (string= "~" op)) nil)
102       ((or (string= "before" op)) 100)
103       ((or (string= ":=" op) (string= "o" op)) 130)
104       ((or (string= ">" op) (string= ">=" op) (string= "<>" op)
105            (string= "<" op) (string= "<=" op) (string= "=" op)) 140)
106       ((or (string= "::" op) (string= "@" op)) 150)
107       ((or (string= "+" op) (string= "-" op) (string= "^" op)) 160)
108       ((or (string= "/" op) (string= "*" op)
109            (string= "quot" op) (string= "rem" op)
110            (string= "div" op) (string= "mod" op)) 170)
111       ;; default heuristic: alphanum symbols are not infix
112       ;;((or (string-match "\\sw" op)) nil)
113       ;;(t 100)
114       (t nil)
115       ))
116    
117    ;;
118    
119  (defun sml-forward-spaces ()  (defun sml-forward-spaces ()
120    (let ((parse-sexp-lookup-properties t))    (let ((parse-sexp-lookup-properties t))
121      (forward-comment 100000)))      (forward-comment 100000)))
# Line 134  Line 148 
148               (t (error "Unbalanced")))))               (t (error "Unbalanced")))))
149      t))      t))
150    
 ;; (defun sml-forward-sexp (&optional count strict)  
 ;;   "Moves one sexp forward if possible, or one char else.  
 ;; Returns T if the move indeed moved through one sexp and NIL if not."  
 ;;   (let ((parse-sexp-lookup-properties t)  
 ;;      (parse-sexp-ignore-comments t))  
 ;;     (condition-case ()  
 ;;      (progn  
 ;;        (forward-sexp 1)  
 ;;        (cond  
 ;;         ((sml-looking-back-at  
 ;;           (if strict sml-begin-symbols-re sml-user-begin-symbols-re))  
 ;;          (sml-find-match-forward sml-begin-symbols-re "\\<end\\>") t)  
 ;;         ((sml-looking-back-at "\\<end\\>") nil)  
 ;;         (t t)))  
 ;;       (error (forward-char 1) nil))))  
   
 ;; the terminators should be chosen more carefully:  
 ;; `let' isn't one while `=' may be  
 ;; (defun sml-forward-sexps (&optional end)  
 ;;   (sml-forward-sexp)  
 ;;   (while (not (sml-looking-back-at (or end (concat sml-keywords-regexp "\\|[])}|:;]"))))  
 ;;       (sml-forward-sexp)))  
   
151  ;;  ;;
152  ;; now backwards  ;; now backwards
153  ;;  ;;
# Line 204  Line 195 
195            (ignore-errors (backward-sexp 1))            (ignore-errors (backward-sexp 1))
196            (if (/= point (point)) t (backward-char 1) nil)))            (if (/= point (point)) t (backward-char 1) nil)))
197         ;; let...end atoms         ;; let...end atoms
198         ((or (string-equal "end" op)         ((or (string= "end" op)
199              (and (not prec)              (and (not prec)
200                   (or (string-equal "in" op) (string-equal "with" op))))                   (or (string= "in" op) (string= "with" op))))
201          (sml-find-match-backward "\\<end\\>" sml-begin-symbols-re))          (sml-find-match-backward "\\<end\\>" sml-begin-symbols-re))
202         ;; don't forget the `op' special keyword         ;; don't forget the `op' special keyword
203         ((sml-move-if (progn (sml-backward-spaces) (skip-syntax-backward "w_"))         ((sml-move-if (progn (sml-backward-spaces) (skip-syntax-backward "w_"))
# Line 215  Line 206 
206         ((and (or (not prec) (and prec op-prec (< prec op-prec)))         ((and (or (not prec) (and prec op-prec (< prec op-prec)))
207               (string-match (sml-syms-re sml-exptrail-syms) op))               (string-match (sml-syms-re sml-exptrail-syms) op))
208          (cond          (cond
209           ((or (string-equal "else" op) (string-equal "then" op))           ((or (string= "else" op) (string= "then" op))
210            (sml-find-match-backward "\\<else\\>" "\\<if\\>"))            (sml-find-match-backward "\\<else\\>" "\\<if\\>"))
211           ((string-equal "of" op)           ((string= "of" op)
212            (sml-find-match-backward "\\<of\\>" "\\<case\\>"))            (sml-find-match-backward "\\<of\\>" "\\<case\\>"))
213           ((string-equal "do" op)           ((string= "do" op)
214            (sml-find-match-backward "\\<do\\>" "\\<while\\>"))            (sml-find-match-backward "\\<do\\>" "\\<while\\>"))
215           (t prec)))           (t prec)))
216         ;; infix ops precedence         ;; infix ops precedence
# Line 250  Line 241 
241         ;; let...end atoms         ;; let...end atoms
242         ((or (string-match sml-begin-symbols-re op)         ((or (string-match sml-begin-symbols-re op)
243              (and (not prec)              (and (not prec)
244                   (or (string-equal "in" op) (string-equal "with" op))))                   (or (string= "in" op) (string= "with" op))))
245          (sml-find-match-forward sml-begin-symbols-re "\\<end\\>"))          (sml-find-match-forward sml-begin-symbols-re "\\<end\\>"))
246         ;; don't forget the `op' special keyword         ;; don't forget the `op' special keyword
247         ((string-equal "op" op) (sml-forward-sym))         ((string= "op" op) (sml-forward-sym))
248         ;; infix ops precedence         ;; infix ops precedence
249         ((and prec op-prec) (< prec op-prec))         ((and prec op-prec) (< prec op-prec))
250         ;; [ prec = nil ]  if...then...else         ;; [ prec = nil ]  if...then...else
251         ;; ((or (string-equal "else" op) (string-equal "then" op))         ;; ((or (string= "else" op) (string= "then" op))
252         ;;  (sml-find-match-backward "\\<else\\>" "\\<if\\>"))         ;;  (sml-find-match-backward "\\<else\\>" "\\<if\\>"))
253         ;; [ prec = nil ]  case...of         ;; [ prec = nil ]  case...of
254         ;; ((string-equal "of" op)         ;; ((string= "of" op)
255         ;;  (sml-find-match-backward "\\<of\\>" "\\<case\\>"))         ;;  (sml-find-match-backward "\\<of\\>" "\\<case\\>"))
256         ;; [ prec = nil ]  while...do         ;; [ prec = nil ]  while...do
257         ;; ((string-equal "do" op)         ;; ((string= "do" op)
258         ;;  (sml-find-match-backward "\\<do\\>" "\\<while\\>"))         ;;  (sml-find-match-backward "\\<do\\>" "\\<while\\>"))
259         ;; [ 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
260         (op-prec (while (sml-move-if (sml-forward-sexp op-prec))) t)         (op-prec (while (sml-move-if (sml-forward-sexp op-prec))) t)
# Line 275  Line 266 
266         (t t))))) ;(or (string-match "\\sw" op) (sml-backward-sexp prec))         (t t))))) ;(or (string-match "\\sw" op) (sml-backward-sexp prec))
267    
268  (defun sml-in-word-p ()  (defun sml-in-word-p ()
269    (and (eq ?w (char-syntax (char-before)))    (and (eq ?w (char-syntax (or (char-before) ? )))
270         (eq ?w (char-syntax (char-after)))))         (eq ?w (char-syntax (or (char-after) ? )))))
271    
272  (defun sml-user-backward-sexp (&optional count)  (defun sml-user-backward-sexp (&optional count)
273    "Like `backward-sexp' but tailored to the SML syntax."    "Like `backward-sexp' but tailored to the SML syntax."
# Line 310  Line 301 
301  (defun sml-backward-arg () (sml-backward-sexp 1000))  (defun sml-backward-arg () (sml-backward-sexp 1000))
302  (defun sml-forward-arg () (sml-forward-sexp 1000))  (defun sml-forward-arg () (sml-forward-sexp 1000))
303    
 ;; (defun sml-backward-arg ()  
 ;;   "Moves one sexp backward (and return T) if it is an argument."  
 ;;   (let* ((point (point))  
 ;;       (argp (and (sml-backward-sexp t)  
 ;;                  (not (looking-at sml-not-arg-re))  
 ;;                  (save-excursion  
 ;;                    (sml-forward-sexp 1 t)  
 ;;                    (sml-forward-spaces)  
 ;;                    (>= (point) point)))))  
 ;;     (unless argp (goto-char point))  
 ;;     argp))  
   
 ;; (defun sml-backward-sexps (&optional end)  
 ;;   (sml-backward-spaces)  
 ;;   (let ((eos (point)))  
 ;;     (sml-backward-sexp t)  
 ;;     (while (not (save-restriction  
 ;;                (narrow-to-region (point) eos)  
 ;;                (looking-at (or end sml-keywords-regexp))))  
 ;;       (sml-backward-spaces)  
 ;;       (setq eos (point))  
 ;;       (sml-backward-sexp t))  
 ;;     (if (looking-at "\\sw")  
 ;;      (forward-word 1)  
 ;;       (forward-char))  
 ;;     (sml-forward-spaces)))  
   
 ;; (defun sml-up-list ()  
 ;;   (save-excursion  
 ;;     (condition-case ()  
 ;;         (progn  
 ;;           (up-list 1)  
 ;;           (point))  
 ;;       (error 0))))  
   
304  ;;  ;;
305  (provide 'sml-move)  (provide 'sml-move)

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

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