[MLton-commit] r5253
Vesa Karvonen
vesak at mlton.org
Sun Feb 18 05:27:09 PST 2007
Mostly refactoring. Moved compatibility stuff to a separate file.
----------------------------------------------------------------------
U mlton/trunk/ide/emacs/bg-job.el
A mlton/trunk/ide/emacs/compat.el
U mlton/trunk/ide/emacs/def-use-mode.el
U mlton/trunk/ide/emacs/def-use-util.el
U mlton/trunk/ide/emacs/esml-du-mlton.el
U mlton/trunk/ide/emacs/esml-gen.el
U mlton/trunk/ide/emacs/esml-mlb-mode.el
U mlton/trunk/ide/emacs/esml-util.el
----------------------------------------------------------------------
Modified: mlton/trunk/ide/emacs/bg-job.el
===================================================================
--- mlton/trunk/ide/emacs/bg-job.el 2007-02-18 02:08:45 UTC (rev 5252)
+++ mlton/trunk/ide/emacs/bg-job.el 2007-02-18 13:27:08 UTC (rev 5253)
@@ -3,6 +3,9 @@
;; MLton is released under a BSD-style license.
;; See the file MLton-LICENSE for details.
+(require 'compat)
+(require 'cl)
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Customization
@@ -45,7 +48,8 @@
A job may call `bg-job-start' to start new jobs and multiple background
jobs may be active simultaneously."
- (push (cons args (cons done? (cons step finalize))) bg-job-queue)
+ (let ((job (cons args (cons done? (cons step finalize)))))
+ (push job bg-job-queue))
(bg-job-timer-start))
(defun bg-job-done? (job)
@@ -68,7 +72,7 @@
(defun bg-job-timer-stop ()
(when bg-job-timer
- (def-use-delete-timer bg-job-timer)
+ (compat-delete-timer bg-job-timer)
(setq bg-job-timer nil)))
(defun bg-job-quantum ()
Added: mlton/trunk/ide/emacs/compat.el
===================================================================
--- mlton/trunk/ide/emacs/compat.el 2007-02-18 02:08:45 UTC (rev 5252)
+++ mlton/trunk/ide/emacs/compat.el 2007-02-18 13:27:08 UTC (rev 5253)
@@ -0,0 +1,36 @@
+;; Copyright (C) 2007 Vesa Karvonen
+;;
+;; MLton is released under a BSD-style license.
+;; See the file MLton-LICENSE for details.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Gnu Emacs / XEmacs compatibility workarounds
+
+(if (string-match "XEmacs" emacs-version)
+ (defun compat-replace-regexp-in-string (str regexp rep)
+ (replace-in-string str regexp rep t))
+ (defun compat-replace-regexp-in-string (str regexp rep)
+ (replace-regexp-in-string regexp rep str t t)))
+
+(if (string-match "XEmacs" emacs-version)
+ (defun compat-error (str &rest objs)
+ (error 'error (concat "Error: " (apply (function format) str objs) ".")))
+ (defalias 'compat-error (function error)))
+
+(if (string-match "XEmacs" emacs-version)
+ (defalias 'compat-add-local-hook (function add-local-hook))
+ (defun compat-add-local-hook (hook fn)
+ (add-hook hook fn nil t)))
+
+(if (string-match "XEmacs" emacs-version)
+ (defun compat-abbreviate-file-name (file)
+ (abbreviate-file-name file t))
+ (defalias 'compat-abbreviate-file-name (function abbreviate-file-name)))
+
+(if (string-match "XEmacs" emacs-version)
+ (defalias 'compat-delete-timer (function delete-itimer))
+ (defalias 'compat-delete-timer (function cancel-timer)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(provide 'compat)
Property changes on: mlton/trunk/ide/emacs/compat.el
___________________________________________________________________
Name: svn:eol-style
+ native
Modified: mlton/trunk/ide/emacs/def-use-mode.el
===================================================================
--- mlton/trunk/ide/emacs/def-use-mode.el 2007-02-18 02:08:45 UTC (rev 5252)
+++ mlton/trunk/ide/emacs/def-use-mode.el 2007-02-18 13:27:08 UTC (rev 5253)
@@ -50,6 +50,13 @@
:group 'faces
:group 'def-use)
+(defface def-use-view-face
+ '((((class color)) (:background "chocolate1"))
+ (t (:background "gray")))
+ "Face for marking the definition or use currently being viewed."
+ :group 'faces
+ :group 'def-use)
+
(defcustom def-use-delay 0.125
"Idle time in seconds to delay before updating highlighting."
:type '(number :tag "seconds")
@@ -197,7 +204,7 @@
position."
(cond
((not (file-readable-p (def-use-ref-src ref)))
- (def-use-error "Referenced file %s can not be read" (def-use-ref-src ref)))
+ (compat-error "Referenced file %s can not be read" (def-use-ref-src ref)))
(other-window
(def-use-find-file (def-use-ref-src ref) t))
((not (equal (def-use-buffer-file-truename) (def-use-ref-src ref)))
@@ -216,7 +223,7 @@
(function def-use-ref<)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; List
+;; List mode
(defconst def-use-ref-regexp "\\([^ ]+\\):\\([0-9]+\\)\\.\\([0-9]+\\)")
@@ -256,7 +263,7 @@
(switch-to-buffer-other-window buffer)
(buffer-disable-undo)
(def-use-list-mode)
- (def-use-add-local-hook
+ (compat-add-local-hook
'kill-buffer-hook (function def-use-list-view-unmark-all))
(set (make-local-variable 'def-use-list-sym)
sym)
@@ -291,8 +298,7 @@
(when (and def-use-list-ref-to-overlay-alist
def-use-list-sym)
(save-window-excursion
- (let ((b (current-buffer))
- (length (length (def-use-sym-name def-use-list-sym))))
+ (let ((length (length (def-use-sym-name def-use-list-sym))))
(mapc (function
(lambda (ref-overlay)
(unless (cdr ref-overlay)
@@ -425,7 +431,7 @@
(defun def-use-delete-highlight-timer ()
(when def-use-highlight-timer
- (def-use-delete-timer def-use-highlight-timer)
+ (compat-delete-timer def-use-highlight-timer)
(setq def-use-highlight-timer nil)))
(defun def-use-create-highlight-timer ()
Modified: mlton/trunk/ide/emacs/def-use-util.el
===================================================================
--- mlton/trunk/ide/emacs/def-use-util.el 2007-02-18 02:08:45 UTC (rev 5252)
+++ mlton/trunk/ide/emacs/def-use-util.el 2007-02-18 13:27:08 UTC (rev 5253)
@@ -3,19 +3,15 @@
;; MLton is released under a BSD-style license.
;; See the file MLton-LICENSE for details.
+(require 'compat)
(require 'cl)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Utilities
-;; workaround for incompatibility between GNU Emacs and XEmacs
-(if (string-match "XEmacs" emacs-version)
- (defun def-use-error (str &rest objs)
- (error 'error (concat "Error: " (apply (function format) str objs) ".")))
- (defalias 'def-use-error (function error)))
-
-;; In Gnu Emacs, `buffer-file-truename' is abbreviated while in XEmacs
-;; it isn't.
+;; In Gnu Emacs, `buffer-file-truename' is abbreviated while in XEmacs it
+;; isn't. This isn't in compat.el, because we want to use our cached
+;; version of `file-truename', namely `def-use-file-truename'.
(defun def-use-buffer-file-truename ()
"Returns the true filename of the current buffer."
(let ((name (buffer-file-name)))
@@ -26,16 +22,6 @@
(make-hash-table :test 'equal :weakness 'key)
"Weak hash table private to `def-use-file-truename'.")
-(if (string-match "XEmacs" emacs-version)
- (defalias 'def-use-add-local-hook (function add-local-hook))
- (defun def-use-add-local-hook (hook fn)
- (add-hook hook fn nil t)))
-
-(if (string-match "XEmacs" emacs-version)
- (defun def-use-abbreviate-file-name (file)
- (abbreviate-file-name file t))
- (defalias 'def-use-abbreviate-file-name (function abbreviate-file-name)))
-
(defun def-use-file-truename (file)
"Cached version of `file-truename' combined with `abbreviate-file-name'."
(def-use-gethash-or-put file
@@ -43,7 +29,7 @@
(lambda ()
(def-use-intern
(def-use-add-face 'font-lock-keyword-face
- (def-use-abbreviate-file-name (file-truename file))))))
+ (compat-abbreviate-file-name (file-truename file))))))
def-use-file-truename-table))
(defun def-use-find-buffer-visiting-file (file)
@@ -90,10 +76,6 @@
"Returns the current line number counting from 1."
(+ 1 (count-lines 1 (def-use-point-at-current-line))))
-(if (string-match "XEmacs" emacs-version)
- (defalias 'def-use-delete-timer (function delete-itimer))
- (defalias 'def-use-delete-timer (function cancel-timer)))
-
(defun def-use-gethash-or-put (key_ mk-value_ table_)
(or (gethash key_ table_)
(puthash key_ (funcall mk-value_) table_)))
@@ -142,16 +124,19 @@
(add-text-properties 0 (length string) `(face ,face) string)
string)
-(defun def-use-attr-mod-time-as-double (attr)
- (+ (* (car (nth 5 attr)) 65536.0) (cadr (nth 5 attr))))
+(defun def-use-time-to-double (time)
+ "Converts a time to a double."
+ (+ (* (car time) 65536.0)
+ (cadr time)
+ (if (cddr time) (* (caddr time) 1e-06) 0)))
(defun def-use-attr-newer? (attr1 attr2)
"Returns non-nil iff the modification time of `attr1' is later than the
modification time of `attr2'. Note that this also returns nil when either
one of the modification times is nil."
(and attr1 attr2
- (> (def-use-attr-mod-time-as-double attr1)
- (def-use-attr-mod-time-as-double attr2))))
+ (> (def-use-time-to-double (nth 5 attr1))
+ (def-use-time-to-double (nth 5 attr2)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Modified: mlton/trunk/ide/emacs/esml-du-mlton.el
===================================================================
--- mlton/trunk/ide/emacs/esml-du-mlton.el 2007-02-18 02:08:45 UTC (rev 5252)
+++ mlton/trunk/ide/emacs/esml-du-mlton.el 2007-02-18 13:27:08 UTC (rev 5253)
@@ -107,7 +107,7 @@
(esml-du-stop-parsing ctx)
(let ((timer (esml-du-ctx-poll-timer ctx)))
(when timer
- (def-use-delete-timer timer)
+ (compat-delete-timer timer)
(esml-du-ctx-set-poll-timer nil ctx))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -176,6 +176,7 @@
(let ((buffer (esml-du-ctx-buf ctx)))
(when buffer
(with-current-buffer buffer
+ (goto-char 1)
(when (search-forward (esml-du-ref-to-appx-syntax ref) nil t)
(beginning-of-line)
(while (= ?\ (char-after))
@@ -231,7 +232,7 @@
(insert-file (esml-du-ctx-duf ctx))
(setq buffer-read-only t)
(goto-char 1)
- (def-use-add-local-hook
+ (compat-add-local-hook
'kill-buffer-hook
(lexical-let ((ctx ctx))
(function
Modified: mlton/trunk/ide/emacs/esml-gen.el
===================================================================
--- mlton/trunk/ide/emacs/esml-gen.el 2007-02-18 02:08:45 UTC (rev 5252)
+++ mlton/trunk/ide/emacs/esml-gen.el 2007-02-18 13:27:08 UTC (rev 5253)
@@ -84,7 +84,7 @@
(let* ((fields (esml-extract-field-names pattern-or-type))
(n (length fields)))
(if (< n 2)
- (esml-error "%s" "Record must have at least two fields")
+ (compat-error "%s" "Record must have at least two fields")
(let ((fields (sort fields 'string-lessp))
(start (point)))
(labels ((format-fields
@@ -95,24 +95,24 @@
for i from 1 to n
do (insert
(let* ((result fmt)
- (result (esml-replace-regexp-in-string
+ (result (compat-replace-regexp-in-string
result "\\%f" f))
- (result (esml-replace-regexp-in-string
+ (result (compat-replace-regexp-in-string
result "\\%i" (int-to-string i))))
result)))
(delete-char -2) ;; TBD
(buffer-string))))
(insert
(let* ((result (nth 0 esml-gen-fru-setter-template))
- (result (esml-replace-regexp-in-string
+ (result (compat-replace-regexp-in-string
result "%1" (format-fields (nth 1 esml-gen-fru-setter-template))))
- (result (esml-replace-regexp-in-string
+ (result (compat-replace-regexp-in-string
result "%2" (format-fields (nth 2 esml-gen-fru-setter-template))))
- (result (esml-replace-regexp-in-string
+ (result (compat-replace-regexp-in-string
result "%3" (format-fields (nth 3 esml-gen-fru-setter-template))))
- (result (esml-replace-regexp-in-string
+ (result (compat-replace-regexp-in-string
result "%4" (format-fields (nth 4 esml-gen-fru-setter-template))))
- (result (esml-replace-regexp-in-string
+ (result (compat-replace-regexp-in-string
result "%n" (int-to-string n))))
result))
(indent-region start (point) nil))))))
@@ -144,14 +144,14 @@
(interactive "nMaximum number of fields [2-100]: ")
(if (not (and (<= 2 n)
(<= n 100)))
- (esml-error "%s" "Number of fields must be between 2 and 100")
+ (compat-error "%s" "Number of fields must be between 2 and 100")
(labels ((format-fields
(fmt n)
(with-temp-buffer
(loop for i from 1 to n
do (insert
(let* ((result fmt)
- (result (esml-replace-regexp-in-string
+ (result (compat-replace-regexp-in-string
result "%i" (int-to-string i))))
result)))
(delete-char -2) ;; TBD
@@ -162,17 +162,17 @@
(insert "\n"))
(insert
(let* ((result (nth 0 esml-gen-ftu-setters-template))
- (result (esml-replace-regexp-in-string
+ (result (compat-replace-regexp-in-string
result "%1" (format-fields (nth 1 esml-gen-ftu-setters-template) i)))
- (result (esml-replace-regexp-in-string
+ (result (compat-replace-regexp-in-string
result "%2" (format-fields (nth 2 esml-gen-ftu-setters-template) i)))
- (result (esml-replace-regexp-in-string
+ (result (compat-replace-regexp-in-string
result "%3" (format-fields (nth 3 esml-gen-ftu-setters-template) i)))
- (result (esml-replace-regexp-in-string
+ (result (compat-replace-regexp-in-string
result "%4" (format-fields (nth 4 esml-gen-ftu-setters-template) i)))
- (result (esml-replace-regexp-in-string
+ (result (compat-replace-regexp-in-string
result "%5" (format-fields (nth 5 esml-gen-ftu-setters-template) i)))
- (result (esml-replace-regexp-in-string
+ (result (compat-replace-regexp-in-string
result "%n" (int-to-string i))))
result)))
(indent-region start (point) nil)))))
Modified: mlton/trunk/ide/emacs/esml-mlb-mode.el
===================================================================
--- mlton/trunk/ide/emacs/esml-mlb-mode.el 2007-02-18 02:08:45 UTC (rev 5252)
+++ mlton/trunk/ide/emacs/esml-mlb-mode.el 2007-02-18 13:27:08 UTC (rev 5253)
@@ -238,7 +238,7 @@
(let* ((name (match-string 1))
(name-value (assoc name esml-mlb-path-variables)))
(unless name-value
- (esml-error "Unknown path variable: %s" name))
+ (compat-error "Unknown path variable: %s" name))
(delete-char (length (match-string 0)))
(insert (cdr name-value)))
(forward-char 1)
@@ -664,9 +664,9 @@
(interactive)
;; TBD: find-error / error output mode
(unless (eq major-mode 'esml-mlb-mode)
- (esml-error "show-basis is only meaningful on MLB files"))
+ (compat-error "show-basis is only meaningful on MLB files"))
(when (get-process esml-mlb-show-basis-process-name)
- (esml-error "show-basis already running"))
+ (compat-error "show-basis already running"))
(save-some-buffers)
(lexical-let ((tmp-file (concat
(file-name-directory (buffer-file-name))
@@ -674,15 +674,15 @@
".basis"))
(buffer (get-buffer-create esml-mlb-show-basis-process-name)))
(when (file-exists-p tmp-file)
- (esml-error "Temporary basis file already exists: %s" tmp-file))
+ (compat-error "Temporary basis file already exists: %s" tmp-file))
(save-excursion
(set-buffer buffer)
(delete-region (point-min) (point-max)))
(let ((process (start-process-shell-command
esml-mlb-show-basis-process-name
buffer
- (esml-replace-regexp-in-string
- (esml-replace-regexp-in-string
+ (compat-replace-regexp-in-string
+ (compat-replace-regexp-in-string
esml-mlb-show-basis-command
"%t"
tmp-file)
Modified: mlton/trunk/ide/emacs/esml-util.el
===================================================================
--- mlton/trunk/ide/emacs/esml-util.el 2007-02-18 02:08:45 UTC (rev 5252)
+++ mlton/trunk/ide/emacs/esml-util.el 2007-02-18 13:27:08 UTC (rev 5253)
@@ -46,19 +46,6 @@
(defun esml-split-string (string separator)
(remove* "" (split-string string separator) :test 'equal))
-;; workaround for incompatibility between GNU Emacs and XEmacs
-(if (string-match "XEmacs" emacs-version)
- (defun esml-replace-regexp-in-string (str regexp rep)
- (replace-in-string str regexp rep t))
- (defun esml-replace-regexp-in-string (str regexp rep)
- (replace-regexp-in-string regexp rep str t t)))
-
-;; workaround for incompatibility between GNU Emacs and XEmacs
-(if (string-match "XEmacs" emacs-version)
- (defun esml-error (str &rest objs)
- (error 'error (concat "Error: " (apply (function format) str objs) ".")))
- (defalias 'esml-error (function error)))
-
(defun esml-string-matches-p (regexp str)
"Non-nil iff the entire string matches the regexp."
(and (string-match regexp str)
More information about the MLton-commit
mailing list