[MLton-commit] r5103

[Vesa Karvonen]

Moved background processor to a separate source file.

----------------------------------------------------------------------

A   mlton/trunk/ide/emacs/bg-job.el
U   mlton/trunk/ide/emacs/def-use-util.el
U   mlton/trunk/ide/emacs/esml-def-use-mlton.el

----------------------------------------------------------------------

Copied: mlton/trunk/ide/emacs/bg-job.el (from rev 5102, mlton/trunk/ide/emacs/def-use-util.el)
===================================================================
--- mlton/trunk/ide/emacs/def-use-util.el	2007-02-01 01:23:30 UTC (rev 5102)
+++ mlton/trunk/ide/emacs/bg-job.el	2007-02-01 07:45:36 UTC (rev 5103)
@@ -0,0 +1,57 @@
+;; Copyright (C) 2007 Vesa Karvonen
+;;
+;; MLton is released under a BSD-style license.
+;; See the file MLton-LICENSE for details.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Background Processor
+
+(defun bg-job-start (done? step finalize &rest args)
+  "Starts a background job."
+  (push (cons args (cons done? (cons step finalize))) bg-jobs)
+  (unless (cdr bg-jobs)
+    (bg-job-reschedule)))
+
+(defun bg-job-done? (job)
+  (apply (cadr job) (car job)))
+
+(defun bg-job-step (job)
+  (setcar job (apply (caddr job) (car job))))
+
+(defun bg-job-finalize (job)
+  (apply (cdddr job) (car job)))
+
+(defvar bg-jobs nil)
+
+(defconst bg-job-period 0.03)
+(defconst bg-job-cpu-ratio 0.3)
+
+(defun bg-job-reschedule ()
+  (when bg-jobs
+    (run-with-timer
+     (/ bg-job-period bg-job-cpu-ratio)
+     nil
+     (function bg-job-quantum))))
+
+(defun bg-job-quantum ()
+  (let ((start-time (bg-job-time-to-double (current-time))))
+    (while (and bg-jobs
+                (< (- (bg-job-time-to-double (current-time))
+                      start-time)
+                   bg-job-period))
+      (let ((job (pop bg-jobs)))
+        (if (bg-job-done? job)
+            (bg-job-finalize job)
+          (bg-job-step job)
+          (setq bg-jobs
+                (nconc bg-jobs (list job)))))))
+  (bg-job-reschedule))
+
+(defun bg-job-time-to-double (time)
+  (+ (* (car time) 65536.0)
+     (cadr time)
+     (/ (caddr time) 1000000.0)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(provide 'bg-job)

Modified: mlton/trunk/ide/emacs/def-use-util.el
===================================================================
--- mlton/trunk/ide/emacs/def-use-util.el	2007-02-01 01:23:30 UTC (rev 5102)
+++ mlton/trunk/ide/emacs/def-use-util.el	2007-02-01 07:45:36 UTC (rev 5103)
@@ -92,55 +92,6 @@
   (add-text-properties 0 (length string) `(face ,face) string)
   string)
 
-(defun def-use-time-to-double (time)
-  (+ (* (car time) 65536.0)
-     (cadr time)
-     (/ (caddr time) 1000000.0)))
-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Background Processor
 
-(defun def-use-bg-job (done? step finalize args)
-  (cons args (cons done? (cons step finalize))))
-(defun def-use-bg-job-done? (job)
-  (apply (cadr job) (car job)))
-(defun def-use-bg-job-step (job)
-  (setcar job (apply (caddr job) (car job))))
-(defun def-use-bg-job-finalize (job)
-  (apply (cdddr job) (car job)))
-
-(defvar def-use-bg-jobs nil)
-
-(defconst def-use-bg-job-period 0.03)
-(defconst def-use-bg-job-cpu-ratio 0.3)
-
-(defun def-use-bg-job-reschedule ()
-  (when def-use-bg-jobs
-    (run-with-timer
-     (/ def-use-bg-job-period def-use-bg-job-cpu-ratio)
-     nil
-     (function def-use-bg-job-quantum))))
-
-(defun def-use-start-bg-job (done? step finalize &rest args)
-  (let ((schedule (not def-use-bg-jobs)))
-    (push (def-use-bg-job done? step finalize args) def-use-bg-jobs)
-    (when schedule
-      (def-use-bg-job-reschedule))))
-
-(defun def-use-bg-job-quantum ()
-  (let ((start-time (def-use-time-to-double (current-time))))
-    (while (and def-use-bg-jobs
-                (< (- (def-use-time-to-double (current-time))
-                      start-time)
-                   def-use-bg-job-period))
-      (let ((job (pop def-use-bg-jobs)))
-        (if (def-use-bg-job-done? job)
-            (def-use-bg-job-finalize job)
-          (def-use-bg-job-step job)
-          (setq def-use-bg-jobs
-                (nconc def-use-bg-jobs (list job)))))))
-  (def-use-bg-job-reschedule))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
 (provide 'def-use-util)

Modified: mlton/trunk/ide/emacs/esml-def-use-mlton.el
===================================================================
--- mlton/trunk/ide/emacs/esml-def-use-mlton.el	2007-02-01 01:23:30 UTC (rev 5102)
+++ mlton/trunk/ide/emacs/esml-def-use-mlton.el	2007-02-01 07:45:36 UTC (rev 5103)
@@ -5,6 +5,7 @@
 
 (require 'def-use-mode)
 (require 'sml-mode)
+(require 'bg-job)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Parsing of def-use -files produced by MLton.
@@ -60,7 +61,7 @@
       (goto-char 1)
       (setq buffer-read-only t))
     (message (concat "Parsing " duf " in the background..."))
-    (def-use-start-bg-job
+    (bg-job-start
       (function
        (lambda (duf buf)
          (with-current-buffer buf