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/trunk/sml-mode.el
ViewVC logotype

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

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

revision 2721, Tue Jun 12 16:43:58 2007 UTC revision 2722, Fri Jun 15 01:32:05 2007 UTC
# Line 417  Line 417 
417  (defun sml-mode-variables ()  (defun sml-mode-variables ()
418    (set-syntax-table sml-mode-syntax-table)    (set-syntax-table sml-mode-syntax-table)
419    (setq local-abbrev-table sml-mode-abbrev-table)    (setq local-abbrev-table sml-mode-abbrev-table)
   ;; A paragraph is separated by blank lines or ^L only.  
   
420    (set (make-local-variable 'indent-line-function) 'sml-indent-line)    (set (make-local-variable 'indent-line-function) 'sml-indent-line)
421    (set (make-local-variable 'comment-start) "(* ")    (set (make-local-variable 'comment-start) "(* ")
422    (set (make-local-variable 'comment-end) " *)")    (set (make-local-variable 'comment-end) " *)")
423    (set (make-local-variable 'comment-nested) t)    (set (make-local-variable 'comment-start-skip) "(\\*+\\s-*")
424    ;;(set (make-local-variable 'block-comment-start) "* ")    (set (make-local-variable 'comment-end-skip) "\\s-*\\*+)")
425    ;;(set (make-local-variable 'block-comment-end) "")    ;; No need to quote nested comments markers.
426    ;; (set (make-local-variable 'comment-column) 40)    (set (make-local-variable 'comment-quote-nested) nil))
   (set (make-local-variable 'comment-start-skip) "(\\*+\\s-*"))  
427    
428  (defun sml-funname-of-and ()  (defun sml-funname-of-and ()
429    "Name of the function this `and' defines, or nil if not a function.    "Name of the function this `and' defines, or nil if not a function.
# Line 594  Line 591 
591  (defsubst sml-bolp ()  (defsubst sml-bolp ()
592    (save-excursion (skip-chars-backward " \t|") (bolp)))    (save-excursion (skip-chars-backward " \t|") (bolp)))
593    
594    (defun sml-first-starter-p ()
595      "Non-nil if starter at point is immediately preceded by let/local/in/..."
596      (save-excursion
597        (let ((sym (unless (save-excursion (sml-backward-arg))
598                     (sml-backward-spaces)
599                     (sml-backward-sym))))
600          (if (member sym '(";" "d=")) (setq sym nil))
601          sym)))
602    
603    
604  (defun sml-indent-starter (orig-sym)  (defun sml-indent-starter (orig-sym)
605    "Return the indentation to use for a symbol in `sml-starters-syms'.    "Return the indentation to use for a symbol in `sml-starters-syms'.
606  Point should be just before the symbol ORIG-SYM and is not preserved."  Point should be just before the symbol ORIG-SYM and is not preserved."
# Line 604  Line 611 
611      (if sym (sml-get-sym-indent sym)      (if sym (sml-get-sym-indent sym)
612        ;; FIXME: this can take a *long* time !!        ;; FIXME: this can take a *long* time !!
613        (setq sym (sml-find-matching-starter sml-starters-syms))        (setq sym (sml-find-matching-starter sml-starters-syms))
614          (if (or (sml-first-starter-p)
615        ;; Don't align with `and' because it might be specially indented.        ;; Don't align with `and' because it might be specially indented.
616        (if (and (or (equal orig-sym "and") (not (equal sym "and")))                (and (or (equal orig-sym "and") (not (equal sym "and")))
617                 (sml-bolp))                     (sml-bolp)))
618            (+ (current-column)            (+ (current-column)
619               (if (and sml-rightalign-and (equal orig-sym "and"))               (if (and sml-rightalign-and (equal orig-sym "and"))
620                   (- (length sym) 3) 0))                   (- (length sym) 3) 0))
# Line 849  Line 857 
857  (defmacro sml-def-skeleton (name interactor &rest elements)  (defmacro sml-def-skeleton (name interactor &rest elements)
858    (when (fboundp 'define-skeleton)    (when (fboundp 'define-skeleton)
859      (let ((fsym (intern (concat "sml-form-" name))))      (let ((fsym (intern (concat "sml-form-" name))))
860          ;; TODO: don't do the expansion in comments and strings.
861        `(progn        `(progn
862           (add-to-list 'sml-forms-alist ',(cons name fsym))           (add-to-list 'sml-forms-alist ',(cons name fsym))
863           (condition-case err           (condition-case err
# Line 974  Line 983 
983      (message "Macro bound to %s" fsym)      (message "Macro bound to %s" fsym)
984      (add-to-list 'sml-forms-alist (cons name fsym))))      (add-to-list 'sml-forms-alist (cons name fsym))))
985    
986  ;;;;  ;;;
987  ;;;;  SML/NJ's Compilation Manager support  ;;; MLton support
988  ;;;;  ;;;
989    
990    (defvar sml-mlton-command "mlton"
991      "Command to run MLton.   Can include arguments.")
992    
993    (defvar sml-mlton-mainfile nil)
994    
995    (defun sml-mlton-typecheck (mainfile)
996      "typecheck using MLton."
997      (interactive
998       (list (if (and mainfile (not current-prefix-arg))
999                 mainfile
1000               (read-file-name "Main file: "))))
1001      (save-some-buffers)
1002      (require 'compile)
1003      (add-to-list
1004       'compilation-error-regexp-alist
1005       ;; I wish they just changed MLton to use one of the standard
1006       ;; error formats.
1007       `("^\\(?:Error\\|\\(Warning\\)\\): \\(.+\\) \\([0-9]+\\)\\.\\([0-9]+\\)\\."
1008         2 3 4
1009         ;; If subgroup 1 matched, then it's a warning, otherwise it's an error.
1010         ,@(if (fboundp 'compilation-fake-loc) '((1)))))
1011      (with-current-buffer (find-file-noselect mainfile)
1012        (compile (concat sml-mlton-command
1013                         " -stop tc "       ;Stop right after type checking.
1014                         (shell-quote-argument
1015                          (file-relative-name buffer-file-name))))))
1016    
1017    ;;;
1018    ;;; MLton's def-use info.
1019    ;;;
1020    
1021    (defvar sml-defuse-file nil)
1022    
1023    (defun sml-defuse-file ()
1024      (or sml-defuse-file (sml-defuse-set-file)))
1025    
1026    (defun sml-defuse-set-file ()
1027      "Specify the def-use file to use."
1028      (interactive)
1029      (setq sml-defuse-file (read-file-name "Def-use file: ")))
1030    
1031    (defun sml-defuse-symdata-at-point ()
1032      (save-excursion
1033        (sml-forward-sym)
1034        (let ((symname (sml-backward-sym)))
1035          (if (equal symname "op")
1036              (save-excursion (setq symname (sml-forward-sym))))
1037          (when (string-match "op " symname)
1038            (setq symname (substring symname (match-end 0)))
1039            (forward-word)
1040            (sml-forward-spaces))
1041          (list symname
1042                ;; Def-use files seem to count chars, not columns.
1043                ;; We hope here that they don't actually count bytes.
1044                ;; Also they seem to start counting at 1.
1045                (1+ (- (point) (progn (beginning-of-line) (point))))
1046                (save-restriction
1047                  (widen) (1+ (count-lines (point-min) (point))))
1048                buffer-file-name))))
1049    
1050    (defconst sml-defuse-def-regexp
1051      "^[[:alpha:]]+ \\([^ \n]+\\) \\(.+\\) \\([0-9]+\\)\\.\\([0-9]+\\)$")
1052    (defconst sml-defuse-use-regexp-format "^    %s %d\\.%d $")
1053    
1054    (defun sml-defuse-jump-to-def ()
1055      "Jump to the definition corresponding to the symbol at point."
1056      (interactive)
1057      (let ((symdata (sml-defuse-symdata-at-point)))
1058        (if (null (car symdata))
1059            (error "Not on a symbol")
1060          (with-current-buffer (find-file-noselect (sml-defuse-file))
1061            (goto-char (point-min))
1062            (unless (re-search-forward
1063                     (format sml-defuse-use-format
1064                             (concat "\\(?:"
1065                                     ;; May be an absolute file name.
1066                                     (regexp-quote (nth 3 symdata))
1067                                     "\\|"
1068                                     ;; Or a relative file name.
1069                                     (regexp-quote (file-relative-name
1070                                                    (nth 3 symdata)))
1071                                     "\\)")
1072                             (nth 2 symdata)
1073                             (nth 1 symdata))
1074                     nil t)
1075              ;; FIXME: This is typically due to editing: any minor editing will
1076              ;; mess everything up.  We should try to fail more gracefully.
1077              (error "Def-use info not found"))
1078            (unless (re-search-backward sml-defuse-def-regexp nil t)
1079              ;; This indicates a bug in this code.
1080              (error "Internal failure while looking up def-use"))
1081            (unless (equal (match-string 1) (nth 0 symdata))
1082              ;; FIXME: This again is most likely due to editing.
1083              (error "Incoherence in the def-use info found"))
1084            (let ((line (string-to-number (match-string 3)))
1085                  (char (string-to-number (match-string 4))))
1086              (pop-to-buffer (find-file-noselect (match-string 2)))
1087              (goto-line line)
1088              (forward-char (1- char)))))))
1089    
1090    ;;;
1091    ;;; SML/NJ's Compilation Manager support
1092    ;;;
1093    
1094  (defvar sml-cm-mode-syntax-table sml-mode-syntax-table)  (defvar sml-cm-mode-syntax-table sml-mode-syntax-table)
1095  (defvar sml-cm-font-lock-keywords  (defvar sml-cm-font-lock-keywords
# Line 984  Line 1097 
1097                                  "functor" "signature" "funsig") t)                                  "functor" "signature" "funsig") t)
1098              "\\>")))              "\\>")))
1099  ;;;###autoload  ;;;###autoload
 (add-to-list 'completion-ignored-extensions "CM/")  
1100  (add-to-list 'completion-ignored-extensions ".cm/")  (add-to-list 'completion-ignored-extensions ".cm/")
1101    ;; This was used with the old compilation manager.
1102    (add-to-list 'completion-ignored-extensions "CM/")
1103  ;;;###autoload  ;;;###autoload
1104  (add-to-list 'auto-mode-alist '("\\.cm\\'" . sml-cm-mode))  (add-to-list 'auto-mode-alist '("\\.cm\\'" . sml-cm-mode))
1105  ;;;###autoload  ;;;###autoload
# Line 995  Line 1109 
1109    (set (make-local-variable 'font-lock-defaults)    (set (make-local-variable 'font-lock-defaults)
1110         '(sml-cm-font-lock-keywords nil t nil nil)))         '(sml-cm-font-lock-keywords nil t nil nil)))
1111    
1112  ;;;;  ;;;
1113  ;;;; ML-Lex support  ;;; ML-Lex support
1114  ;;;;  ;;;
1115    
1116  (defvar sml-lex-font-lock-keywords  (defvar sml-lex-font-lock-keywords
1117    (append    (append
# Line 1012  Line 1126 
1126    "Major Mode for editing ML-Lex files."    "Major Mode for editing ML-Lex files."
1127    (set (make-local-variable 'font-lock-defaults) sml-lex-font-lock-defaults))    (set (make-local-variable 'font-lock-defaults) sml-lex-font-lock-defaults))
1128    
1129  ;;;;  ;;;
1130  ;;;; ML-Yacc support  ;;; ML-Yacc support
1131  ;;;;  ;;;
1132    
1133  (defface sml-yacc-bnf-face  (defface sml-yacc-bnf-face
1134    '((t (:foreground "darkgreen")))    '((t (:foreground "darkgreen")))

Legend:
Removed from v.2721  
changed lines
  Added in v.2722

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